From 94a337b9beeef879df5555d22b03a4070ca86af5 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Tue, 4 Jun 2019 09:50:10 -0600 Subject: [PATCH 01/19] scidoc update --- physics/docs/library.bib | 12 +- physics/docs/pdftxt/suite_input.nml.txt | 635 +++++++++++++++--------- 2 files changed, 425 insertions(+), 222 deletions(-) diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 4836aceba..d34d2f3fa 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,13 +1,23 @@ %% This BibTeX bibliography file was created using BibDesk. %% http://bibdesk.sourceforge.net/ -%% Created for Man Zhang at 2019-05-24 12:46:55 -0600 +%% Created for Man Zhang at 2019-05-31 14:47:36 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{nakanishi_2000, + Author = {M. Nakanishi }, + Date-Added = {2019-05-31 14:46:02 -0600}, + Date-Modified = {2019-05-31 14:47:32 -0600}, + Journal = {Boundary-Layer Meteorology}, + Pages = {461-493}, + Title = {Large-eddy simulation of radiation fog}, + Volume = {94}, + Year = {2000}} + @article{Gehne_2019, Author = {Gehne, Maria and Hamill, Thomas M. and Bates, Gary T. and Pegion, Philip and Kolczynski, Walter}, Date-Added = {2019-05-24 12:46:43 -0600}, diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 6e90827b7..e88051aaa 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -3,233 +3,426 @@ \section gfs_physics_nml GFS Physics Parameters The namelist variable description is provided in host-model side: GFS_typedefs.F90 +
option DDT in Host Model Description Default Value -
\b &gfs_physics_nml +
\b &gfs_physics_nml
fhzero gfs_control_type hour between clearing of diagnostic buckets 0.0
h2o_phys gfs_control_type flag for stratosphere h2o scheme .false.
ldiag3d gfs_control_type flag for 3D diagnostic fields .false. +
lssav gfs_control_type logical flag for storing diagnostics .false. +
lgocart gfs_control_type logical flag for 3D diagnostic fields for gocart 1 .false. +
cplflx gfs_control_type logical flag for cplflx collection .false. +
cplwav gfs_control_type logical flag for cplwav collection .false. +
cplchm gfs_control_type logical flag for chemistry collection .false. +
lsidea gfs_control_type logical flag for idealized physics .false.
oz_phys gfs_control_type flag for old (2006) ozone physics .true.
oz_phys_2015 gfs_control_type flag for new (2015) ozone physics .false. - fhcyc | gfs_typedefs::gfs_control_type | frequency for surface data cycling in hours | 0.0 | - use_ufo | gfs_typedefs::gfs_control_type | flag for using unfiltered orography surface option | .false. | - pre_rad | gfs_typedefs::gfs_control_type | flag for testing purpose | .false. | - ncld | gfs_typedefs::gfs_control_type | number of hydrometeors | 1 | - +
fhcyc gfs_control_type frequency for surface data cycling in hours 0.0 +
use_ufo gfs_control_type flag for using unfiltered orography surface option .false. +
pre_rad gfs_control_type flag for testing purpose .false. +
ncld gfs_control_type number of hydrometeors 1 +
imp_physics gfs_control_type choice of microphysics scheme: \n +
    +
  • 11: GFDL microphysics scheme +
  • 8: Thompson microphysics scheme +
  • 10: Morrison-Gettelman microphysics scheme +
+ 		99 +
pdfcld gfs_control_type flag for PDF clouds .false. +
fhswr gfs_control_type frequency for shortwave radiation (secs) 3600. +
fhlwr gfs_control_type frequency for longwave radiation (secs) 3600. +
levr gfs_control_type number of vertical levels for radiation calculations -99 +
nfxr gfs_control_type second dimension of radiation input/output array fluxr 39+6 +
iflip gfs_control_type control flag for vertical index direction \n +
    +
  • 0: index from TOA to surface +
  • 1: index from surface to TOA +
+ 		1 +
icliq_sw gfs_control_type sw optical property for liquid clouds \n +
    +
  • 0: input cloud optical depth, ignoring iswcice setting +
  • 1: cloud optical property scheme based on Hu and Stamnes (1993) \cite hu_and_stamnes_1993 method +
  • 2: cloud optical property scheme based on Hu and Stamnes (1993) \cite hu_and_stamnes_1993 - updated +
+ 		1 +
iovr_sw gfs_control_type control flag for cloud overlap in SW radiation \n +
    +
  • 0: random overlapping clouds +
  • 1: max/ran overlapping clouds +
  • 2: maximum overlap clouds (mcica only) +
  • 3: decorrelation-length overlap (mcica only) +
+ 		1 +
iovr_lw gfs_control_type control flag for cloud overlap in LW radiation \n +
    +
  • 0: random overlapping clouds +
  • 1: max/ran overlapping clouds +
  • 2: maximum overlap clouds (mcica only) +
  • 3: decorrelation-length overlap (mcica only) +
+ 		1 +
ictm gfs_control_type external data time/date control flag \n +
    +
  • -2: same as 0, but superimpose seasonal cycle from climatology data set +
  • -1: use user provided external data for the forecast time, no extrapolation +
  • 0: use data at initial condition time, if not available, use latest, no extrapolation +
  • 1: use data at the forecast time, if not available, use latest and extrapolation +
  • yyyy0: use yyyy data for the forecast time, no further data extrapolation +
  • yyyy1: use yyyy data for the forecast. if needed, do extrapolation to match the fcst time +
+ 		1 +
crick_proof gfs_control_type control flag for eliminating CRICK \n +
    +
  • .true.: apply layer smoothing to eliminate CRICK +
  • .false.: do not apply layer smoothing +
+ 		.false. +
ccnorm gfs_control_type control flag for in-cloud condensate mixing ratio \n +
    +
  • .true.: normalize cloud condensate +
  • .false.: not normalize cloud condensate +
+ 		.false. +
norad_precip gfs_control_type control flag for not using precip in radiation (Ferrier scheme) \n +
    +
  • .true.: snow/rain has no impact on radiation +
  • .false.: snow/rain has impact on radiation +
+ 		.false. +
ialb gfs_control_type SW surface albedo control flag: \n +
    +
  • 0: using climatology surface albedo scheme for SW +
  • 1: using MODIS based land surface albedo for SW +
+ 		0 +
iems gfs_control_type LW surface emissivity control flag (ab 2-digit integer) : \n +
    +
  • a: =0 set surface air/ground t same for LW radiation +
  • =1 set surface air/ground t diff for LW radiation +
  • b: =0 use fixed surface emissivity = 1.0 (black-body) +
  • =1 use varying climatology surface emissivity (veg based) +
  • =2 future development (not yet) +
+ 		0 +
iaer gfs_control_type aerosol flag "abc" (volcanic, LW, SW): \n +
    +
  • a: stratospheric volcanic aerosols +
  • b: tropospheric aerosols for LW +
  • c: tropospheric aerosols for SW \n + 0: aerosol effect is not included; \n + 1: aerosol effect is included +
+ 		1 +
ico2 gfs_control_type \f$CO_2\f$ data source control flag:\n +
    +
  • 0: prescribed value (380 ppmv) +
  • 1: yearly global averaged annual mean from observations +
  • 2: monthly 15 degree horizontal resolution from observations +
+ 		0 +
isubc_sw gfs_control_type subgrid cloud approximation control flag in SW radiation: \n +
    +
  • 0: no McICA approximation in SW radiation +
  • 1: use McICA with prescribed permutation seeds (test mode) +
  • 2: use McICA with randomly generated permutation seeds +
+ 		0 +
isubc_lw gfs_control_type subgrid cloud approximation control flag in LW radiation: \n +
    +
  • 0: no McICA approximation in LW radiation +
  • 1: use McICA with prescribed permutatition seeds (test mode) +
  • 2: use McICA with randomly generated permutation seeds +
+ 		0 +
isol gfs_control_type solar constant scheme control flag: \n +
    +
  • 0: fixed value = 1366.0 \f$W m^{-2}\f$ (old standard) +
  • 10: fixed value = 1360.8 \f$W m^{-2}\f$ (new standard) +
  • 1: NOAA ABS-scale TSI table (yearly) with 11-yr cycle approximation +
  • 2: NOAA TIM-scale TSI table (yearly) with 11-yr cycle approximation +
  • 3: CMIP5 TIM-scale TSI table (yearly) with 11-yr cycle approximation +
  • 4: CMIP5 TIM-scale TSI table (monthly) with 11-yr cycle approximation +
+ 		0 +
lwhtr gfs_control_type logical flag for output of longwave heating rate .true. +
swhtr gfs_control_type logical flag for output of shortwave heating rate .true. +
cnvgwd gfs_control_type logical flag for convective gravity wave drag scheme .false. +
shal_cnv gfs_control_type logical flag for calling shallow convection .false. +
lmfshal gfs_control_type flag for mass-flux shallow convection scheme in the cloud fraction calculation shal_cnv .and. (imfshalcnv > 0) +
lmfdeep2 gfs_control_type flag for mass-flux deep convection scheme in the cloud fraction calculation imfdeepcnv == 2 .or. 3 .or.4 +
cal_pre gfs_control_type logical flag for calling precipitation type algorithm .false. +
redrag gfs_control_type logical flag for applying reduced drag coefficient for high wind over sea in GFS surface layer scheme .false. +
dspheat gfs_control_type logical flag for using TKE dissipative heating to temperature tendency in hybrid EDMF and TKE-EDMF schemes .false. +
hybedmf gfs_control_type logical flag for calling hybrid EDMF PBL scheme .false. +
random_clds gfs_control_type logical flag for whether clouds are random .false. +
trans_trac gfs_control_type logical flag for convective transport of tracers .false. +
lheatstrg gfs_control_type logical flag for canopy heat storage parameterization .false. +
shinhong gfs_control_type flag for scale-aware Shinhong PBL scheme .false. +
do_ysu gfs_control_type flag for YSU PBL scheme .false. +
cnvcld gfs_control_type logical flag for convective cloud .false. +
imfshalcnv gfs_control_type flag for mass flux shallow convective scheme:\n +
    +
  • 1:July 2010 version of mass-flux shallow convective scheme (operational as of 2016) +
  • 2: scale- & aerosol-aware mass-flux shallow convective scheme (2017) +
  • 3: scale- & aerosol-aware Grell-Freitas scheme (GSD) +
  • 4: New Tiedtke scheme (CAPS) +
  • 0: modified Tiedtke's eddy-diffusion shallow convective scheme +
  • -1: no shallow convection used +
+ 		1 +
imfdeepcnv gfs_control_type flag for mass-flux deep convective scheme:\n +
    +
  • 1: July 2010 version of SAS convective scheme (operational version as of 2016) +
  • 2: scale- & aerosol-aware mass-flux deep convective scheme (2017) +
  • 3: scale- & aerosol-aware Grell-Freitas scheme (GSD) +
  • 4: New Tiedtke scheme (CAPS) +
+ 		1 +
lgfdlmprad gfs_control_type flag for GFDL mp scheme and radiation consistency .false. +
cdmbgwd(2) gfs_control_type multiplication factors for mountain blocking and orographic gravity wave drag /2.0d0,0.25d0/ +
prslrd0 gfs_control_type pressure level above which to apply Rayleigh damping 0.0d0 +
lsm gfs_control_type flag for land surface model to use \n +
    +
  • 0: OSU LSM +
  • 1: NOAH LSM +
  • 2: RUC LSM +
+ 		1 +
lsoil gfs_control_type number of soil layers 4 +
ivegsrc gfs_control_type flag for vegetation type dataset choice: \n +
    +
  • 0: USGS +
  • 1: IGBP(20 category) +
  • 2: UMD (13 category) +
+ 		2 +
isot gfs_control_type flag for soil type dataset choice:\n +
    +
  • 0: Zobler soil type (9 category) +
  • 1: STATSGO soil type (19 category) +
+ 		0 +
mom4ice gfs_control_type flag controls mom4 sea ice .false. +
debug gfs_control_type flag for debug printout .false. +
nstf_name(5) gfs_control_type NSST related paramters:\n +
    +
  • nstf_name(1): 0=NSSTM off, 1= NSSTM on but uncoupled, 2= NSSTM on and coupled +
  • nstf_name(2): 1=NSSTM spin up on, 0=NSSTM spin up off +
  • nstf_name(3): 1=NSST analysis on, 0=NSSTM analysis off +
  • nstf_name(4): zsea1 in mm +
  • nstf_name(5): zesa2 in mm +
+ 		/0,0,1,0,5/ +
nst_anl gfs_control_type flag for NSSTM analysis in gcycle/sfcsub .false. +
satmedmf gfs_control_type logical flag for calling TKE EDMF PBL scheme .false. +
effr_in gfs_control_type logical flag for using input cloud effective radii calculation .false. +
aero_in gfs_control_type logical flag for using aerosols in Morrison-Gettelman microphysics .false. +
iau_delthrs gfs_control_type incremental analysis update (IAU) time interval in hours 6 +
iaufhrs gfs_control_type forecast hours associated with increment files -1 +
\b CPT_v0 \b Suite \b Specific \b Parameters +
crtrh(3) gfs_control_type critical relative humidity at the surface, PBL top and at the top of the atmosphere /0.90d0,0.90d0,0.90d0/ +
ras gfs_control_type logical flag for RAS convection scheme .false. +
cscnv gfs_control_type logical flag for Chikira-Sugiyama deep convection .false. +
do_aw gfs_control_type flag for Arakawa-Wu scale-awere adjustment .false. +
do_awdd gfs_control_type flag to enable treating convective tendencies following Arakwaw-Wu for downdrafts (2013) .false. +
do_sb_physics gfs_control_type logical flag for SB2001 autoconversion or accretion .true. +
do_cldice gfs_control_type flag for cloud ice processes for MG microphysics .true. +
hetfrz_classnuc gfs_control_type flag for heterogeneous freezing for MG microphysics .false. +
mg_nccons gfs_control_type flag for constant droplet concentration for MG microphysics .false. +
mg_nicons gfs_control_type flag for constant ice concentration for MG microphysics .false. +
mg_ngcons gfs_control_type flag for constant graupel concentration for MG microphysics .false. +
sed_supersat gfs_control_type flag for allowing supersaturation after sedimentation for MG microphysics .true. +
mg_do_graupel gfs_control_type flag for turning on prognostic graupel (with fprcp=2) .true. +
mg_do_hail gfs_control_type flag for turning on prognostic hail (with fprcp=2) .false. +
shcnvcw gfs_control_type logical flag for shallow convective cloud .false. +
xkzm_h gfs_control_type background vertical diffusion for heat and q 1.0d0 +
xkzm_m gfs_control_type background vertical diffusion for momentum 1.0d0 +
xkzm_s gfs_control_type sigma threshold for background mom. diffusion 1.0d0 +
microp_uniform gfs_control_type logical flag for uniform subcolumns for MG microphysics .true. +
mg_do_ice_gmao gfs_control_type logical flag for turning on gmao ice autoconversion in MG microphysics .false. +
mg_do_liq_liu gfs_control_type logical flag for turning on Liu liquid treatment in MG microphysics .true. +
mg_dcs gfs_control_type autoconversion size threshold for cloud ice to snow in MG microphysics 200.0 +
mg_alf gfs_control_type tuning factor for alphas (alpha = 1 - critical relative humidity) 1.0 +
mg_ts_auto_ice(2) gfs_control_type autoconversion time scale for ice in MG microphysics /180.0,180.0/ +
mg_qcvar gfs_control_type cloud water relative variance in MG microphysics 1.0 +
mg_rhmini gfs_control_type relative humidity threshold parameter for nucleating ice 1.01 +
mg_ncnst gfs_control_type constant droplet num concentration \f$m^{-3}\f$ 100.e6 +
mg_ninst gfs_control_type constant ice num concentration \f$m^{-3}\f$ 0.15e6 +
mg_ngnst gfs_control_type constant graupel/hail num concertration \f$m^{-3}\f$ 0.10e6 +
mg_berg_eff_factor gfs_control_type berg efficiency factor 2.0 +
mg_qcmin(2) gfs_control_type min liquid and ice mixing ratio in MG macro clouds /1.0d-9, 1.0d-9/ +
mg_precip_frac_method gfs_control_type type of precipitation fraction method 'max_overlap' +
fprcp gfs_control_type number of frozen precipitation species in MG microphysics \n +
    +
  • 0: no prognostic rain and snow +
  • 1: MG2 +
  • 2: MG3 +
+ 		0 +
pdfflag gfs_control_type pdf flag for MG macro physics 4 +
cs_parm(10) gfs_control_type tunable parameters for Chikira-Sugiyama convection /8.0,4.0,1.0e3,3.5e3,20.0,1.0,-999.,1.,0.6,0./ +
iccn gfs_control_type flag for using IN and CCN forcing in MG2/3 microphysics .false. +
rhcmax gfs_control_type maximum critical relative humidity 0.9999999 +
\b GSD_v0 \b Suite \b Specific \b Parameters +
make_number_concentrations gfs_control_type flag to calculate initial number concentrations from mass concentrations if not in ICs/BCs .false. +
ltaerosol gfs_control_type logical flag for using aerosol climotology in Thompson MP scheme .false. +
lradar gfs_control_type logical flag for computing radar reflectivity in Thompson MP scheme .false. +
ttendlim gfs_control_type temperature tendency limiter per time step in K/s, set to < 0 to deactivate -999.0 +
do_mynnedmf gfs_control_type flag to activate MYNN-EDMF scheme .false. +
do_mynnsfclay gfs_control_type flag to activate MYNN-SFCLAY scheme .false. +
grav_settling gfs_control_type flag to activate gravitational settling of cloud droplets as described in Nakanishi (2000) \cite nakanishi_2000 0 +
bl_mynn_mixlength gfs_control_type flag for different version of mixing length formulation \n +
    +
  • 0: Original form from Nakanishi and Niino (2009) \cite NAKANISHI_2009 . NO scale-awareness is applied to the master mixing length, regardless of "scaleware" setting +
  • 1: HRRR operational form 201609-201807. Designed to work without the mass-flux scheme. Uses BouLac mixing length in free atmosphere. +
  • 2: HRRR operational form 201807-present. Designed to be compatible with mass-flux scheme activated (default) +
+ 		2 +
bl_mynn_edmf gfs_control_type flag to activate the mass-flux scheme \n +
    +
  • 0: Deactivate mass-flux scheme +
  • 1: Activate dynamic multiplume mass-flux scheme +
+ 		0 +
bl_mynn_edmf_mom gfs_control_type flag to activate the transport of momentum \n +
    +
  • 0: Deactivate momentum transport in mass-flux scheme +
  • 1: Activate momentum transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 +
+ 		1 +
bl_mynn_edmf_tke gfs_control_type flag to activate the transport of TKE \n +
    +
  • 0: Deactivate TKE transport in mass-flux scheme +
  • 1: Activate TKE transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 +
+ 		0 +
bl_mynn_edmf_part gfs_control_type flag to partitioning the MF and ED areas 0 +
bl_mynn_edmf_tkeadvect gfs_control_type activate computation of TKE advection (not yet in use for FV3) \n +
    +
  • False: Deactivate TKE advection +
  • True: Activate TKE advection +
+ 		.false. +
bl_mynn_edmf_tkebudget gfs_control_type flag to activate TKE budget 0 +
bl_mynn_edmf_cloudpdf gfs_control_type flag to determine which cloud PDF to use \n +
    +
  • 0: use Sommeria-Deardorff subgrid cloud PDF +
  • 1: use Kuwano-Yoshida subgrid cloud PDF +
  • 2: use modified Chaboureau-Bechtold subgrid cloud PDF +
+ 		2 +
bl_mynn_edmf_cloudmix gfs_control_type flag to activate mixing of cloud species \n +
    +
  • 0: Deactivate the mixing of any water species mixing ratios +
  • 1: activate the mixing of all water species mixing ratios +
+ 		1 +
bl_mynn_mixqt gfs_control_type flag to mix total water or individual species \n +
    +
  • 0: Mix individual water species separately +
  • 1: DO NOT USE +
+ 		0 +
icloud_bl gfs_control_type flag to coupling SGS clouds to radiation \n +
    +
  • 0: Deactivate coupling subgrid clouds to radiation +
  • 1: Activate subgrid cloud coupling to radiation (highly suggested) +
+ 		1 +
lsoil_lsm gfs_control_type number of soil layers internal to land surface model -1 +
\b Stochastic \Physics \b Specific \b Parameters +
do_sppt gfs_control_type flag for stochastic SPPT option .false. +
do_shum gfs_control_type flag for stochastic SHUM option .false. +
do_skeb gfs_control_type flag for stochastic SKEB option .false. +
do_sfcperts gfs_control_type flag for stochastic surface perturbations option .false. +
\b sfcperts +
nsfcpert gfs_control_type number of weights for stochastic surface perturbation 0 +
pertz0 gfs_control_type magnitude of perturbation of momentum roughness length -999. +
pertzt gfs_control_type magnitude of perturbation of heat to momentum roughness length ratio -999. +
pertshc gfs_control_type magnitude of perturbation of soil hydraulic conductivity -999. +
pertlai gfs_control_type magnitude of perturbation of leaf area index -999. +
pertalb gfs_control_type magnitude of surface albedo perturbation -999. +
pertvegf gfs_control_type magnitude of perturbation of vegetation fraction -999. +
iseed_sfc compns_stochy_mod random seeds (if 0 use system clock) 0 +
sfc_tau compns_stochy_mod time scales -999. +
sfc_lscale compns_stochy_mod length scales -999. +
sppt_land compns_stochy_mod .false. +
\b stochy +
use_zmtnblck compns_stochy_mod flag for mountain blocking. .T. = do not apply perturbations below the dividing streamline that is diagnosed by the gravity wave drag, mountain blocking scheme .false. +
ntrunc compns_stochy_mod spectral resolution (e.g. T126) of random patterns -999 +
lon_s, lat_s compns_stochy_mod number of longitude and latitude point for the Gaussian grid -999 +
fhstoch compns_stochy_mod forecast hour to write out random pattern in order to restart the pattern for a different forecast (used in DA), file is stoch_out.F -999.0 +
stochini compns_stochy_mod set to true if wanting to read in a previous random pattern (input file need to be named \c stoch_ini) .false. +
sppt compns_stochy_mod amplitude of random patterns -999. +
sppt_tau compns_stochy_mod decorrelation timescales in seconds -999. +
sppt_lscale compns_stochy_mod decorrelation spatial scales in meters -999. +
sppt_logit compns_stochy_mod logit transform for SPPT to bounded interval [-1,+1] .false. +
iseed_sppt compns_stochy_mod seeds for setting the random number sequence (ignored if \c stochini is true) 0 +
sppt_sigtop1, sppt_sigtop2 compns_stochy_mod sigma levels to taper perturbations to zeros 0.1, 0.025 +
sppt_sfclimit compns_stochy_mod reduce amplitude of SPPT near surface (lowest 2 levels) .false. +
shum compns_stochy_mod amplitude of stochastic boundary layer specific humidity perturbations -999. +
shum_tau compns_stochy_mod decorrelation time scales in seconds -999. +
shum_lscale compns_stochy_mod decorrelation spatial scales in meters -999. +
shum_sigefold compns_stochy_mod e-folding lengthscale (in units of sigma) of specific humidity perturbations 0.2 +
skeb compns_stochy_mod stochastic KE backscatter amplitude -999. +
skeb_tau compns_stochy_mod decorrelation timescales in seconds -999. +
skeb_lscale compns_stochy_mod decorrelation spatial scales in meter -999. +
iseed_skeb compns_stochy_mod seeds for setting the random number sequnce (ignored if \c stochini is true) 0 +
skeb_vfilt compns_stochy_mod 0 +
skebnorm compns_stochy_mod 0: random pattern is stream function,1: pattern is kenorm, 2: pattern is vorticity 0 +
skeb_varspect_opt compns_stochy_mod Gaussian or power law variance spectrum for SKEB (0: Gaussian, 1: power law) 0 +
skeb_npass compns_stochy_mod number of passes of smoother for dissipation estimate 11 +
skeb_vdof compns_stochy_mod the number of degrees of freedom in the vertical for the SKEB random pattern 5 +
skeb_sigtop1, skeb_sigtop2 compns_stochy_mod sigma levels to taper perturbations to zeros 0.1, 0.025 +
skebint compns_stochy_mod 0 +
\b GFDL \b Cloud \b Microphysics \b Parameters +
sedi_transport gfdl_cloud_microphys_mod logical flag for turning on horizontal momentum transport during sedimentation .true. +
do_sedi_heat gfdl_cloud_microphys_mod logical flag for turning on horizontal heat transport during sedimentation .true. +
rad_snow gfdl_cloud_microphys_mod logical flag for considering snow in cloud fraction calculation .true. +
rad_graupel gfdl_cloud_microphys_mod logical flag for considering graupel in cloud fraction calculation .true. +
rad_rain gfdl_cloud_microphys_mod logical flag for considering rain in cloud fraction calculation .true. +
const_vi gfdl_cloud_microphys_mod logical flag for using constant cloud ice fall speed .false. +
const_vs gfdl_cloud_microphys_mod logical flag for using constant snow fall speed .false. +
const_vg gfdl_cloud_microphys_mod logical flag for using constant graupel fall speed .false. +
const_vr gfdl_cloud_microphys_mod logical flag for using constant rain fall speed .false. +
vi_max gfdl_cloud_microphys_mod maximum fall speed for cloud ice 0.5 +
vs_max gfdl_cloud_microphys_mod maximum fall speed for snow 5.0 +
vg_max gfdl_cloud_microphys_mod maximum fall speed for graupel 8.0 +
vr_max gfdl_cloud_microphys_mod maximum fall speed for rain 12.0 +
qi_lim gfdl_cloud_microphys_mod cloud ice limiter to prevent large ice built up in cloud ice freezing and deposition 1. +
prog_ccn gfdl_cloud_microphys_mod logical flag for activating prognostic CCN (not supported in GFS Physics) .false. +
do_qa gfdl_cloud_microphys_mod logical flag for activating inline cloud fraction diagnosis in fast saturation adjustment .true. +
fast_sat_adj gfdl_cloud_microphys_mod logical flag for adjusting cloud water evaporation/freezing, cloud ice deposition when fast saturation adjustment is activated .true. +
tau_l2v gfdl_cloud_microphys_mod time scale for evaporation of cloud water to water vapor. Increasing(decreasing) \p tau_l2v can decrease(boost) deposition of cloud water to water vapor 300. +
tau_v2l gfdl_cloud_microphys_mod time scale for condensation of water vapor to cloud water. Increasing(decreasing) \p tau_v2l can decrease(boost) condensation of water vapor to cloud water 150. +
tau_g2v gfdl_cloud_microphys_mod time scale for sublimation of graupel to water vapor. Increasing(decreasing) \p tau_g2v can decrease(boost) sublimation of graupel to water vapor 900. +
rthresh gfdl_cloud_microphys_mod critical cloud water radius for autoconversion (cloud water -> rain). Increasing(decreasing) of \p rthresh makes the autoconversion harder(easier) 10.0e-6 +
dw_land gfdl_cloud_microphys_mod base value for subgrid deviation/variability over land 0.20 +
dw_ocean gfdl_cloud_microphys_mod base value for subgrid deviation/variability over ocean 0.10 +
ql_gen gfdl_cloud_microphys_mod maximum value for cloud water generated from condensation of water vapor (water vapor-> cloud water) 1.0e-3 +
ql_mlt gfdl_cloud_microphys_mod maximum value of cloud water allowed from melted cloud ice (cloud ice -> cloud water or rain) 2.0e-3 +
qi0_crt gfdl_cloud_microphys_mod threshold of cloud ice to snow autoconversion (cloud ice -> snow) 1.0e-4 +
qs0_crt gfdl_cloud_microphys_mod threshold of snow to graupel autoconversion (snow -> graupel) 1.0e-3 +
tau_i2s gfdl_cloud_microphys_mod time scale for autoconversion of cloud ice to snow 1000. +
c_psaci gfdl_cloud_microphys_mod accretion efficiency of cloud ice to snow 0.02 +
c_pgacs gfdl_cloud_microphys_mod accretion efficiency of snow to graupel 2.0e-3 +
rh_inc gfdl_cloud_microphys_mod relative humidity increment for complete evaporation of cloud water and cloud ice 0.25 +
rh_inr gfdl_cloud_microphys_mod relative humidity increment for sublimation of snow 0.25 +
rh_ins gfdl_cloud_microphys_mod relative humidity increment for minimum evaporation of rain 0.25 +
ccn_l gfdl_cloud_microphys_mod base CCN over land \f$cm^{-3}\f$ 270. +
ccn_o gfdl_cloud_microphys_mod base CCN over ocean \f$cm^{-3}\f$ 90. +
c_paut gfdl_cloud_microphys_mod autoconversion efficiency of cloud water to rain 0.55 +
c_cracw gfdl_cloud_microphys_mod accretion efficiency of cloud water to rain 0.9 +
use_ppm gfdl_cloud_microphys_mod \e true to use PPM fall scheme; \e false to use time-implicit monotonic fall scheme .false. +
use_ccn gfdl_cloud_microphys_mod \e true to compute prescribed CCN. It should be .true. when \p prog_ccn = .false. .false. +
mono_prof gfdl_cloud_microphys_mod \e true to turn on terminal fall with monotonic PPM scheme. This is used together with \p use_ppm=.true. .true. +
z_slope_liq gfdl_cloud_microphys_mod \e true to turn on vertically subgrid linear monotonic slope for autoconversion of cloud water to rain .true. +
z_slope_ice gfdl_cloud_microphys_mod \e true to turn on vertically subgrid linear monotonic slope for autoconversion of cloud ice to snow .false. +
de_ice gfdl_cloud_microphys_mod \e true to convert excessive cloud ice to snow to prevent ice over-built from other sources like convection scheme (not supported in GFS physics) .false. +
fix_negative gfdl_cloud_microphys_mod \e true to fix negative water species using nearby points .false. +
icloud_f gfdl_cloud_microphys_mod flag (0,1,or 2) for cloud fraction diagnostic scheme 0 +
mp_time gfdl_cloud_microphys_mod time step of GFDL cloud microphysics 150.
- - - -\section gfs_physics_nml GFS Physics Parameters - option | DDT in Host Model | Description | Default Value | --------------------|---------------------------------|----------------------------------------------------|---------------| - fhzero | gfs_typedefs::gfs_control_type | hour between clearing of diagnostic buckets | 0.0 | - h2o_phys | gfs_typedefs::gfs_control_type | flag for stratosphere h2o scheme | .false. | - ldiag3d | gfs_typedefs::gfs_control_type | flag for 3D diagnostic fields | .false. | - oz_phys | gfs_typedefs::gfs_control_type | flag for old (2006) ozone physics | .true. | - oz_phys_2015 | gfs_typedefs::gfs_control_type | flag for new (2015) ozone physics | .false. | - fhcyc | gfs_typedefs::gfs_control_type | frequency for surface data cycling in hours | 0.0 | - use_ufo | gfs_typedefs::gfs_control_type | flag for using unfiltered orography surface option | .false. | - pre_rad | gfs_typedefs::gfs_control_type | flag for testing purpose | .false. | - ncld | gfs_typedefs::gfs_control_type | number of hydrometeors | 1 | - imp_physics | gfs_typedefs::gfs_control_type | choice of microphysics scheme: \n 11: GFDL microphysics scheme \n 8: GSD Thompson microphysics scheme \n 6: WSMG microphysics scheme \n 10: Morrison-Gettelman microphysics scheme | 99 | - pdfcld | gfs_typedefs::gfs_control_type | flag for PDF clouds | .false. | - fhswr | gfs_typedefs::gfs_control_type | frequency for shortwave radiation (secs) | 3600. | - fhlwr | gfs_typedefs::gfs_control_type | frequency for longwave radiation (secs) | 3600. | - ialb | gfs_typedefs::gfs_control_type | SW surface albedo control flag: \n 0: using climatology surface albedo scheme for SW \n 1: using MODIS based land surface albedo for SW | 0 | - iems | gfs_typedefs::gfs_control_type | LW surface emissivity control flag: \n 0: black-body emissivity \n 1:surface type based climatology in 1 degree horizontal resolution | 0 | - iaer | gfs_typedefs::gfs_control_type | aerosol flag "abc" (volcanic, LW, SW): \n a: stratospheric volcanic aerosols \n b: tropospheric aerosols for LW \n c: tropospheric aerosols for SW.\n 0: aerosol effect is not included; 1: aerosol effect is included | 1 | - ico2 | gfs_typedefs::gfs_control_type | \f$CO_2\f$ data source control flag:\n 0: prescribed value (380 ppmv) \n 1: yearly global averaged annual mean from observations \n 2: monthly 15 degree horizontal resolution from observations| 0 | - isubc_sw | gfs_typedefs::gfs_control_type | subgrid cloud approximation control flag in SW radiation: \n 0: no McICA approximation in SW radiation \n 1: use McICA with prescribed permutation seeds (test mode) \n 2: use McICA with randomly generated permutation seeds | 0 | - isubc_lw | gfs_typedefs::gfs_control_type | subgrid cloud approximation control flag in LW radiation: \n 0: no McICA approximation in LW radiation \n 1: use McICA with prescribed permutation seeds (test mode) \n 2: use McICA with randomly generated permutation seeds | 0 | - isol | gfs_typedefs::gfs_control_type | solar constant scheme control flag: \n 0: fixed value = 1366.0 \f$W m^{-2}\f$ (old standard) \n 10: fixed value =1360.8 \f$W m^{-2}\f$ (new standard) \n 1: NOAA ABS-scale TSI table (yearly) with 11-yr cycle approximation \n 2: NOAA TIM-scale TSI table(yearly) with 11-yr cycle approximation \n 3: CMIP5 TIM-scale TSI table (yearly) with 11-yr cycle approximation \n 4: CMIP5 TIM-scale TSI table (monthly) with 11-yr cycle approximation | 0 | - lwhtr | gfs_typedefs::gfs_control_type | logical flag for output of longwave heating rate | .true. | - swhtr | gfs_typedefs::gfs_control_type | logical flag for output of shortwave heating rate | .true. | - cnvgwd | gfs_typedefs::gfs_control_type | logical flag for convective gravity wave drag scheme | .false. | - shal_cnv | gfs_typedefs::gfs_control_type | logical flag for calling shallow convection | .false. | - cal_pre | gfs_typedefs::gfs_control_type | logical flag for calling precipitation type algorithm | .false. | - redrag | gfs_typedefs::gfs_control_type | logical flag for applying reduced drag coefficient for high wind over sea in GFS surface layer scheme | .false. | - dspheat | gfs_typedefs::gfs_control_type | logical flag for using TKE dissipative heating to temperature tendency in hybrid EDMF and TKE-EDMF schemes | .false. | - hybedmf | gfs_typedefs::gfs_control_type | logical flag for calling hybrid EDMF PBL scheme | .false. | - random_clds | gfs_typedefs::gfs_control_type | logical flag for whether clouds are random | .false. | - trans_trac | gfs_typedefs::gfs_control_type | logical flag for convective transport of tracers | .false. | - cnvcld | gfs_typedefs::gfs_control_type | logical flag for convective cloud | .false. | - imfshalcnv | gfs_typedefs::gfs_control_type | flag for mass flux shallow convective scheme:\n 1:July 2010 version of mass-flux shallow convective scheme (operational as of 2016) \n 2: scale- & aerosol- aware mass-flux shallow convective scheme (2017) \n 0: modified Tiedtke's eddy-diffusion shallow convective scheme \n -1: no shallow convection used | 1 | - imfdeepcnv | gfs_typedefs::gfs_control_type | flag for mass-flux deep convective scheme:\n 1: July 2010 version of SAS convective scheme (operational version as of 2016) \n 2: scale- & aerosol-aware mass-flux deep convective scheme (2017) \n 0: old SAS convective scheme before July 2010 | 1 | - cdmbgwd(2) | gfs_typedefs::gfs_control_type | multiplication factors for mountain blocking and orographic gravity wave drag | /2.0d0,0.25d0/ | - prslrd0 | gfs_typedefs::gfs_control_type | pressure level above which to apply Rayleigh damping | 0.0d0 | - ivegsrc | gfs_typedefs::gfs_control_type | flag for vegetation type dataset choice: \n 0: USGS; 1: IGBP(20 category); 2: UMD (13 category) | 2 | - isot | gfs_typedefs::gfs_control_type | flag for soil type dataset choice:\n 0: Zobler soil type (9 category) \n 1: STATSGO soil type (19 category) | 0 | - debug | gfs_typedefs::gfs_control_type | flag for debug printout | .false. | - nstf_name(5) | gfs_typedefs::gfs_control_type | NSST related paramters:\n flag 0 for no NST; 1 for uncoupled nst; and 2 for coupled NST \n nstf_name(1): 0=NSSTM off, 1= NSSTM on but uncoupled, 2= NSSTM on and coupled \n nstf_name(2): 1=NSSTM spin up on, 0=NSSTM spin up off \n nstf_name(3): 1=NSST analysis on, 0=NSSTM analysis off \n nstf_name(4): zsea1 in mm \n nstf_name(5): zesa2 in mm | /0,0,1,0,5/ | - nst_anl | gfs_typedefs::gfs_control_type | flag for NSSTM analysis in gcycle/sfcsub | .false. | - satmedmf | gfs_typedefs::gfs_control_type | logical flag for calling TKE EDMF PBL scheme | .false. | - -\section cpt_physics_nml EMC CPT Physics Parameters - \c NML_option | Definition in Host Model | Description | Default Value | --------------------|----------------------------------|---------------------------------------------------|-----------------------| - crtrh(3) | gfs_typedefs::gfs_control_type | critical relative humidity at the surface, PBL top and at the top of the atmosphere | /0.90d0,0.90d0,0.90d0/ | - ras | gfs_typedefs::gfs_control_type | logical flag for RAS convection scheme | .false. | - cscnv | gfs_typedefs::gfs_control_type | logical flag for Chikira-Sugiyama deep convection | .false. | - do_aw | gfs_typedefs::gfs_control_type | flag for Arakawa-Wu scale-awere adjustment | .false. | - shcnvcw | gfs_typedefs::gfs_control_type | logical flag for shallow convective cloud | .false. | - xkzm_h | gfs_typedefs::gfs_control_type | background vertical diffusion for heat q | 1.0d0 | - xkzm_m | gfs_typedefs::gfs_control_type | background vertical diffusion for momentum | 1.0d0 | - xkzm_s | gfs_typedefs::gfs_control_type | sigma threshold for background mom. diffusion | 1.0d0 | - microp_uniform | gfs_typedefs::gfs_control_type | logical flag for uniform subcolumns for MG microphysics | .true. | - mg_do_ice_gmao | gfs_typedefs::gfs_control_type | logical flag for turning on gmao ice autoconversion in MG microphysics | .false. | - mg_do_liq_liu | gfs_typedefs::gfs_control_type | logical flag for turning on Liu liquid treatment in MG microphysics | .true. | - mg_dcs | gfs_typedefs::gfs_control_type | autoconversion size threshold for cloud ice to snow in MG microphysics | 200.0 | - mg_alf | gfs_typedefs::gfs_control_type | tuning factor for alphas (alpha = 1 - critical relative humidity) | 1.0 | - mg_ts_auto_ice(2) | gfs_typedefs::gfs_control_type | autoconversion time scale for ice in MG microphysics | /180.0,180.0/ | - mg_qcvar | gfs_typedefs::gfs_control_type | cloud water relative variance in MG microphysics | 1.0 | - fprcp | gfs_typedefs::gfs_control_type | number of frozen precipitation species in MG microphysics \n 0: no prognostic rain and snow, 1: MG2;2:MG3 | 0 | - cs_parm(10) | gfs_typedefs::gfs_control_type | tunable parameters for Chikira-Sugiyama convection | /8.0,4.0,1.0e3,3.5e3,20.0,1.0,-999.,1.,0.6,0./ | - iccn | gfs_typedefs::gfs_control_type | flag for using IN and CCN forcing in MG2/3 microphysics | .false. | - aero_in | gfs_typedefs::gfs_control_type | flag for using aerosols in MG microphysics | .false. | - ctei_rm(2) | gfs_typedefs::gfs_control_type | critical cloud top entrainment instability criteria (used if mstrat=.true.) | /10.0d0,10.0d0/ | - rhcmax | gfs_typedefs::gfs_control_type | maximum critical relative humidity | 0.9999999 | - effr_in | gfs_typedefs::gfs_control_type | logical flag for using input cloud effective radii calculation | .false. | - cplflx | gfs_typedefs::gfs_control_type | logical flag for controlling cplflx collection | .false. | - iau_delthrs | gfs_typedefs::gfs_control_type | incremental analysis update (IAU) time interval in hours | 6 | - iaufhrs | gfs_typedefs::gfs_control_type | forecast hours associated with increment files | -1 | - -\section gsd_hrrr_nml GSD Physics Parameters - \c NML_option | Definition in Host Model | Description | Default Value | ----------------------------|---------------------------------|-----------------------------------------------|-----------------------| - ltaerosol | gfs_typedefs::gfs_control_type | logical flag for using aerosol climotology | .false. | - lradar | gfs_typedefs::gfs_control_type | logical flag for computing radar reflectivity | .false. | - do_mynnedmf | gfs_typedefs::gfs_control_type | flag to activate MYNN-EDMF scheme | .false. | - do_mynnsfclay | gfs_typedefs::gfs_control_type | flag to activate MYNN-SFCLAY scheme | .false. | - lmfshal | gfs_typedefs::gfs_control_type | flag for mass-flux shallow convection scheme in the cloud fraction calculation (lmf=shal_cnv .and. imfshalcnv > 0) | shal_cnv .and. (imfshalcnv > 0) | - bl_mynn_mixlength | gfs_typedefs::gfs_control_type | flag for different version of mixing length formulation \n 0: Original form from Nakanishi and Niino (2009) \cite NAKANISHI_2009 . NO scale-awareness is applied to the master mixing length, regardless of "scaleware" setting \n 1: HRRR operational form 201609-201807.Designed to work without the mass-flux scheme. Uses BouLac mixing length in free atmosphere. \n 2: HRRR operational form 201807-present. Designed to be compatible with mass-flux scheme activated (default) | 2 | - bl_mynn_edmf | gfs_typedefs::gfs_control_type | flag to activate the mass-flux scheme \n 0: Deactivate mass-flux scheme \n 1: Activate dynamic multiplume mass-flux scheme (default) | 0 | - bl_mynn_edmf_mom | gfs_typedefs::gfs_control_type | flag to activate the transport of momentum \n 0: Deactivate momentum transport in mass-flux scheme (default) \n 1: Activate momentum transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 | 1 | - bl_mynn_edmf_tke | gfs_typedefs::gfs_control_type | flag to activate the transport of TKE \n 0: Deactivate TKE transport in mass-flux scheme (default) \n 1: Activate TKE transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 | 0 | - bl_mynn_edmf_tkeadvect | gfs_typedefs::gfs_control_type | activate computation of TKE advection (not yet in use for FV3) \n False: Deactivate TKE advection (default) \n True: Activate TKE advection | .false. | - bl_mynn_edmf_tkebudget | gfs_typedefs::gfs_control_type | flag to activate TKE budget | 0 | - bl_mynn_edmf_cloudpdf | gfs_typedefs::gfs_control_type | flag to determine which cloud PDF to use \n 0: use Sommeria-Deardorff subgrid cloud PDF \n 1: use Kuwano-Yoshida subgrid cloud PDF \n 2: use modified Chaboureau-Bechtold subgrid cloud PDF (default) | 2 | - bl_mynn_edmf_cloudmix | gfs_typedefs::gfs_control_type | flag to activate mixing of cloud species \n: Deactivate the mixing of any water species mixing ratios \n 1: activate the mixing of all water species mixing ratios (default) | 1 | - bl_mynn_mixqt | gfs_typedefs::gfs_control_type | flag to mix total water or individual species \n 0: Mix individual water species separately (default) \n 1: DO NOT USE | 0 | - icloud_bl | gfs_typedefs::gfs_control_type | flag to coupling sgs clouds to radiation \n 0: Deactivate coupling subgrid clouds to radiation \n 1: Activate subgrid cloud coupling to radiation (highly suggested) | 1 | - lsoil_lsm | gfs_typedefs::gfs_control_type | number of soil layers internal to land surface model | -1 | - lsm | gfs_typedefs::gfs_control_type | flag for land surface model | 1 | - -\section stochy_nml Stochastic Physics Parameters - \c NML_option | Definition in Host Model | Description | Default Value | --------------------|--------------------------------|-----------------------------------------------------------------------|---------------| - do_sppt | gfs_typedefs::gfs_control_type | flag for stochastic SPPT option | .false. | - do_shum | gfs_typedefs::gfs_control_type | flag for stochastic SHUM option | .false. | - do_skeb | gfs_typedefs::gfs_control_type | flag for stochastic SKEB option | .false. | - use_zmtnblck | gfs_typedefs::gfs_control_type | flag for mountain blocking | .false. | - do_sfcperts | gfs_typedefs::gfs_control_type | flag for stochastic surface perturbations option | .false. | - nsfcpert | gfs_typedefs::gfs_control_type | number of weights for stochastic surface perturbation | 6 | - pertz0 | gfs_typedefs::gfs_control_type | magnitude of perturbation of momentum roughness length | -999. | - pertzt | gfs_typedefs::gfs_control_type | magnitude of perturbation of heat to momentum roughness length ratio | -999. | - pertshc | gfs_typedefs::gfs_control_type | magnitude of perturbation of soil hydraulic conductivity | -999. | - pertlai | gfs_typedefs::gfs_control_type | magnitude of perturbation of leaf area index | -999. | - pertalb | gfs_typedefs::gfs_control_type | magnitude of surface albedo perturbation | -999. | - pertvegf | gfs_typedefs::gfs_control_type | magnitude of perturbation of vegetation fraction | -999. | - -\subsection gen_stochy_nml General Stochastic Physics Paramters - \c NML_option | Definition in Host Model | Description | Default Value | --------------------|----------------------------|--------------------------------------------------------------|---------------| - ntrunc | compns_stochy_mod | spectral resolution (e.g. T126) of random patterns | -999 | - lon_s, lat_s | compns_stochy_mod | number of longitude and latitude point for the Gaussian grid | -999 | - fhstoch | compns_stochy_mod | forecast hour to write out random pattern in order to restart the pattern for a different forecast (used in DA), file is stoch_out.F | -999.0 | - stochini | compns_stochy_mod | set to true if wanting to read in a previous random pattern (input file need to be named \c stoch_ini) | -999.0 | .false. | - -\subsection sppt_contrl_nml SPPT Control Parameters - \c NML_option | Definition in Host Model | Description | Default Value | --------------------|----------------------------|--------------------------------------------------------------------------------|---------------| - sppt | compns_stochy_mod | amplitude of random patterns | -999. | - sppt_tau | compns_stochy_mod | decorrelation timescales in secods | -999. | - sppt_lscale | compns_stochy_mod | decorrelation spatial scales in meters | -999. | - sppt_logit | compns_stochy_mod | logit transform for SPPT to bounded interval [-1,+1] | .false. | - iseed_sppt | compns_stochy_mod | seeds for setting the random number sequence (ignored if \c stochini is true) | 0 | - sppt_sigtop1, sppt_sigtop2 | compns_stochy_mod | sigma levels to taper perturbations to zeros | 0.1, 0.025 | - sppt_sfclimit | compns_stochy_mod | reduce amplitude of SPPT near surface (lowest 2 levels) | .false. | - use_zmtnblck | gfs_typedefs::gfs_control_type | flag for mountain blocking. .T. = do not apply perturbations below the dividing streamline that is diagnosed by the gravity wave drag, mountain blocking scheme | .false. | - - -\subsection shum_contrl_nml SHUM Control Parameters - \c NML_option | Definition in Host Model | Description | Default Value | --------------------|----------------------------|------------------------------------------------------------------------------|---------------| - shum | compns_stochy_mod | amplitude of stochastic boundary layer specific humidity perturbations | -999. | - shum_tau | compns_stochy_mod | decorrelation time scales in seconds | -999. | - shum_lscale | compns_stochy_mod | decorrelation spatial scales in meters | -999. | - shum_sigefold | compns_stochy_mod | e-folding lengthscale (in units of sigma) of specific humidity perturbations | 0.2 | - -\subsection skeb_contrl_nml SKEB Control Parameters - \c NML_option | Definition in Host Model | Description | Default Value | -------------------------------|----------------------------|------------------------------------------------------------------------------------|---------------| - skeb | compns_stochy_mod | stochastic KE backscatter amplitude | -999. | - skeb_tau | compns_stochy_mod | decorrelation timescales in seconds | -999. | - skeb_lscale | compns_stochy_mod | decorrelation spatial scales in meter | -999. | - iseed_skeb | compns_stochy_mod | seeds for setting the random number sequnce (ignored if \c stochini is true) | 0 | - skebnorm | compns_stochy_mod | 0: random pattern is stream function,1: pattern is kenorm, 2: pattern is vorticity | 0 | - skeb_varspect_opt | compns_stochy_mod | Gaussian or power law variance spectrum for SKEB (0: Gaussian, 1: power law | 0 | - skeb_npass | compns_stochy_mod | number of passes of smoother for dissipation estimate | 11 | - skeb_vdof | compns_stochy_mod | the number of degrees of freedom in the vertical for the SKEB random pattern | 5 | - skeb_sigtop1, skeb_sigtop2 | compns_stochy_mod | sigma levels to taper perturbations to zeros | 0.1, 0.025 | - - - -\section zhao_carr_nml Zhao-Carr MP Parameters - \c NML_option | DDT in Host Model | Description | Default Value | --------------------|---------------------------------|-----------------------------------------------|---------------------| - psautco(2) | gfs_typedefs::gfs_control_type | auto conversion coeff from ice to snow | /6.0d-4,3.0d-4/ | - prautco(2) | gfs_typedefs::gfs_control_type | auto conversion coeff from cloud to rain | /1.0d-4,1.0d-4/ | - -\section gfdl_cloud_microphysics_nml GFDL Cloud MP Parameters -The namelist variable description is provided in module_gfdl_cloud_microphys.F90 - \c NML_option | Definition in CCPP | Description | Default Value | --------------------------|---------------------------|--------------------------------------------------------------------------------|----------------------| - sedi_transport | gfdl_cloud_microphys_mod | logical flag for turning on horizontal momentum transport during sedimentation | .true. | - do_sedi_heat | gfdl_cloud_microphys_mod | logical flag for turning on horizontal heat transport during sedimentation | .true. | - rad_snow | gfdl_cloud_microphys_mod | logical flag for considering snow in cloud fraction calculation | .true. | - rad_graupel | gfdl_cloud_microphys_mod | logical flag for considering graupel in cloud fraction calculation | .true. | - rad_rain | gfdl_cloud_microphys_mod | logical flag for considering rain in cloud fraction calculation | .true. | - const_vi | gfdl_cloud_microphys_mod | logical flag for using constant cloud ice fall speed | .false. | - const_vs | gfdl_cloud_microphys_mod | logical flag for using constant snow fall speed | .false. | - const_vg | gfdl_cloud_microphys_mod | logical flag for using constant graupel fall speed | .false. | - const_vr | gfdl_cloud_microphys_mod | logical flag for using constant rain fall speed | .false. | - vi_max | gfdl_cloud_microphys_mod | maximum fall speed for cloud ice | 0.5 | - vs_max | gfdl_cloud_microphys_mod | maximum fall speed for snow | 5.0 | - vg_max | gfdl_cloud_microphys_mod | maximum fall speed for graupel | 8.0 | - vr_max | gfdl_cloud_microphys_mod | maximum fall speed for rain | 12.0 | - qi_lim | gfdl_cloud_microphys_mod | cloud ice limiter to prevent large ice built up in cloud ice freezing and deposition | 1. | - prog_ccn | gfdl_cloud_microphys_mod | logical flag for activating prognostic CCN (not supported in GFS Physics) | .false. | - do_qa | gfdl_cloud_microphys_mod | logical flag for activating inline cloud fraction diagnosis in fast saturation adjustment | .true. | - fast_sat_adj | gfdl_cloud_microphys_mod | logical flag for adjusting cloud water evaporation/freezing, cloud ice deposition when fast saturation adjustment is activated (do_sat_adj=.true.) | .true. | - tau_l2v | gfdl_cloud_microphys_mod | time scale for evaporation of cloud water to water vapor. Increasing(decreasing) \p tau_l2v can decrease(boost) deposition of cloud water to water vapor | 300. | - tau_v2l | gfdl_cloud_microphys_mod | time scale for condensation of water vapor to cloud water. Increasing(decreasing) \p tau_v2l can decrease(boost) condensation of water vapor to cloud water | 150. | - tau_g2v | gfdl_cloud_microphys_mod | time scale for sublimation of graupel to water vapor. Increasing(decreasing) \p tau_g2v can decrease(boost) sublimation of graupel to water vapor | 900. | - rthresh | gfdl_cloud_microphys_mod | critical cloud water radius for autoconversion (cloud water -> rain). Increasing(decreasing) of \p rthresh makes the autoconversion harder(easier) | 10.0e-6 | - dw_land | gfdl_cloud_microphys_mod | base value for subgrid deviation/variability over land | 0.20 | - dw_ocean | gfdl_cloud_microphys_mod | base value for subgrid deviation/variability over ocean | 0.10 | - ql_gen | gfdl_cloud_microphys_mod | maximum value for cloud water generated from condensation of water vapor (water vapor-> cloud water) | 1.0e-3 | - ql_mlt | gfdl_cloud_microphys_mod | maximum value of cloud water allowed from melted cloud ice (cloud ice -> cloud water or rain) | 2.0e-3 | - qi0_crt | gfdl_cloud_microphys_mod | threshold of cloud ice to snow autoconversion (cloud ice -> snow) | 1.0e-4 | - qs0_crt | gfdl_cloud_microphys_mod | threshold of snow to graupel autoconversion (snow->graupel) | 1.0e-3 | - tau_i2s | gfdl_cloud_microphys_mod | time scale for autoconversion of cloud ice to snow | 1000. | - c_psaci | gfdl_cloud_microphys_mod | accretion efficiency of cloud ice to snow | 0.02 | - c_pgacs | gfdl_cloud_microphys_mod | accretion efficiency of snow to graupel | 2.0e-3 | - rh_inc | gfdl_cloud_microphys_mod | relative humidity increment for complete evaporation of cloud water and cloud ice | 0.25 | - rh_inr | gfdl_cloud_microphys_mod | relative humidity increment for sublimation of snow | 0.25 | - rh_ins | gfdl_cloud_microphys_mod | relative humidity increment for minimum evaporation of rain | 0.25 | - ccn_l | gfdl_cloud_microphys_mod | base CCN over land \f$cm^{-3}\f$ | 270. | - ccn_o | gfdl_cloud_microphys_mod | base CCN over ocean \f$cm^{-3}\f$ | 90. | - c_paut | gfdl_cloud_microphys_mod | autoconversion efficiency of cloud water to rain | 0.55 | - c_cracw | gfdl_cloud_microphys_mod | accretion efficiency of cloud water to rain | 0.9 | - use_ppm | gfdl_cloud_microphys_mod | \e true to use PPM fall scheme; \e false to use time-implicit monotonic fall scheme | .false. | - use_ccn | gfdl_cloud_microphys_mod | \e true to compute prescribed CCN. It should be .true. when \p prog_ccn = .false. | .false. | - mono_prof | gfdl_cloud_microphys_mod | \e true to turn on terminal fall with monotonic PPM scheme. This is used together with \p use_ppm=.true. | .true. | - z_slope_liq | gfdl_cloud_microphys_mod | \e true to turn on vertically subgrid linear monotonic slope for autoconversion of cloud water to rain | .true. | - z_slope_ice | gfdl_cloud_microphys_mod | \e true to turn on vertically subgrid linear monotonic slope for autoconversion of cloud ice to snow | .false. | - de_ice | gfdl_cloud_microphys_mod | \e true to convert excessive cloud ice to snow to prevent ice over-built from other sources like convection scheme (not supported in GFS physics) | .false. | - fix_negative | gfdl_cloud_microphys_mod | \e true to fix negative water species using nearby points | .false. | - icloud_f | gfdl_cloud_microphys_mod | flag (0,1,or 2) for cloud fraction diagnostic scheme | 0 | - mp_time | gfdl_cloud_microphys_mod | time step of GFDL cloud microphysics | 150. | - */ From 80528f287dec77fb90b0e8ee50adff3a0982cf65 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Wed, 5 Jun 2019 14:25:17 -0600 Subject: [PATCH 02/19] scidoc update --- physics/docs/library.bib | 104 ++++----- physics/docs/pdftxt/CPT_CSAW.txt | 2 +- physics/docs/pdftxt/CPT_MG3.txt | 32 ++- physics/docs/pdftxt/CPT_adv_suite.txt | 172 +++++++-------- physics/docs/pdftxt/GFSv15_suite.txt | 212 ++++++++++--------- physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt | 198 +++++++++-------- physics/docs/pdftxt/GSD_adv_suite.txt | 131 ++++++------ physics/docs/pdftxt/all_shemes_list.txt | 76 +++---- physics/docs/pdftxt/suite_input.nml.txt | 44 ++-- physics/micro_mg3_0.F90 | 2 - physics/module_mp_thompson.F90 | 6 +- physics/mp_thompson.F90 | 2 +- physics/satmedmfvdif.F | 23 +- 13 files changed, 495 insertions(+), 509 deletions(-) diff --git a/physics/docs/library.bib b/physics/docs/library.bib index d34d2f3fa..dbc820d07 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,15 +1,27 @@ %% This BibTeX bibliography file was created using BibDesk. %% http://bibdesk.sourceforge.net/ -%% Created for Man Zhang at 2019-05-31 14:47:36 -0600 +%% Created for Man Zhang at 2019-06-05 10:35:17 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{Gettelman_et_al_2019, + Author = {A. Gettelman and H. Morrison and K. Thayer-Calder and C. M. Zarzycki}, + Date-Added = {2019-06-05 16:32:22 +0000}, + Date-Modified = {2019-06-05 16:34:07 +0000}, + Journal = {Journal of Advances in Modeling Earth Systems}, + Title = {The impact of rimed ice hydrometeors on global and regional climate}, + Year = {2019}} + +@article{cite-key, + Date-Added = {2019-06-05 16:32:11 +0000}, + Date-Modified = {2019-06-05 16:32:11 +0000}} + @article{nakanishi_2000, - Author = {M. Nakanishi }, + Author = {M. Nakanishi}, Date-Added = {2019-05-31 14:46:02 -0600}, Date-Modified = {2019-05-31 14:47:32 -0600}, Journal = {Boundary-Layer Meteorology}, @@ -73,16 +85,11 @@ @article{HOBBS_1974 @article{Pichugina_2008, Author = {Pichugina, Yelena L. and Tucker, Sara C. and Banta, Robert M. and Brewer, W. Alan and Kelley, Neil D. and Jonkman, Bonnie J. and Newsom, Rob K.}, Date-Added = {2019-05-22 11:25:17 -0600}, - Date-Modified = {2019-05-22 11:25:17 -0600}, - Doi = {10.1175/2008jtecha988.1}, - Issn = {1520-0426}, + Date-Modified = {2019-06-05 15:59:49 +0000}, Journal = {Journal of Atmospheric and Oceanic Technology}, - Month = {Aug}, Number = {8}, Pages = {1307--1327}, - Publisher = {American Meteorological Society}, Title = {Horizontal-Velocity and Variance Measurements in the Stable Boundary Layer Using Doppler Lidar: Sensitivity to Averaging Procedures}, - Url = {http://dx.doi.org/10.1175/2008JTECHA988.1}, Volume = {25}, Year = {2008}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/2008JTECHA988.1}, @@ -91,16 +98,11 @@ @article{Pichugina_2008 @article{Nielsen_Gammon_2008, Author = {Nielsen-Gammon, John W. and Powell, Christina L. and Mahoney, M. J. and Angevine, Wayne M. and Senff, Christoph and White, Allen and Berkowitz, Carl and Doran, Christopher and Knupp, Kevin}, Date-Added = {2019-05-22 11:19:45 -0600}, - Date-Modified = {2019-05-22 11:19:45 -0600}, - Doi = {10.1175/2007jamc1503.1}, - Issn = {1558-8432}, + Date-Modified = {2019-06-05 15:31:19 +0000}, Journal = {Journal of Applied Meteorology and Climatology}, - Month = {Jan}, Number = {1}, Pages = {27--43}, - Publisher = {American Meteorological Society}, Title = {Multisensor Estimation of Mixing Heights over a Coastal City}, - Url = {http://dx.doi.org/10.1175/2007JAMC1503.1}, Volume = {47}, Year = {2008}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/2007JAMC1503.1}, @@ -286,15 +288,11 @@ @article{Rutter_2009 @article{Essery_2009, Author = {Essery, Richard and Rutter, Nick and Pomeroy, John and Baxter, Robert and St{\"a}hli, Manfred and Gustafsson, David and Barr, Alan and Bartlett, Paul and Elder, Kelly}, Date-Added = {2019-05-06 14:20:27 -0600}, - Date-Modified = {2019-05-20 16:04:05 -0600}, - Doi = {10.1175/2009bams2629.1}, - Issn = {1520-0477}, + Date-Modified = {2019-06-05 16:01:14 +0000}, Journal = {Bulletin of the American Meteorological Society}, Number = {8}, Pages = {1120-1136}, - Publisher = {American Meteorological Society}, Title = {SNOWMIP2: An Evaluation of Forest Snow Process Simulations}, - Url = {http://dx.doi.org/10.1175/2009BAMS2629.1}, Volume = {90}, Year = {2009}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/2009BAMS2629.1}, @@ -436,15 +434,11 @@ @article{Benjamin_2004a @article{Smirnova_2000, Author = {Smirnova, Tatiana G. and Brown, John M. and Benjamin, Stanley G. and Kim, Dongsoo}, - Doi = {10.1029/1999jd901047}, - Issn = {0148-0227}, + Date-Modified = {2019-06-05 15:32:20 +0000}, Journal = {Journal of Geophysical Research: Atmospheres}, - Month = {Feb}, Number = {D3}, Pages = {4077--4086}, - Publisher = {American Geophysical Union (AGU)}, Title = {Parameterization of cold-season processes in the MAPS land-surface scheme}, - Url = {http://dx.doi.org/10.1029/1999JD901047}, Volume = {105}, Year = {2000}, Bdsk-Url-1 = {http://dx.doi.org/10.1029/1999JD901047}} @@ -889,16 +883,11 @@ @article{Thompson_2004 @article{Abdul_Razzak_2000, Author = {Abdul-Razzak, Hayder and Ghan, Steven J.}, Date-Added = {2019-01-22 11:02:36 -0700}, - Date-Modified = {2019-05-20 16:02:47 -0600}, - Doi = {10.1029/1999jd901161}, - Issn = {0148-0227}, + Date-Modified = {2019-06-05 15:28:16 +0000}, Journal = {Journal of Geophysical Research: Atmospheres}, - Month = {Mar}, Number = {D5}, Pages = {6837-6844}, - Publisher = {American Geophysical Union (AGU)}, Title = {A parameterization of aerosol activation: 2. Multiple aerosol types}, - Url = {http://dx.doi.org/10.1029/1999JD901161}, Volume = {105}, Year = {2000}, Bdsk-Url-1 = {http://dx.doi.org/10.1029/1999JD901161}} @@ -1095,16 +1084,11 @@ @article{Lewis_2005 @article{Zhu_2018, Author = {Zhu, Yuejian and Zhou, Xiaqiong and Li, Wei and Hou, Dingchen and Melhauser, Christopher and Sinsky, Eric and Pe{\~n}a, Malaquias and Fu, Bing and Guan, Hong and Kolczynski, Walter and et al.}, Date-Added = {2018-09-07 11:48:50 -0600}, - Date-Modified = {2018-09-07 11:48:50 -0600}, - Doi = {10.1029/2018jd028506}, - Issn = {2169-897X}, + Date-Modified = {2019-06-05 15:33:03 +0000}, Journal = {Journal of Geophysical Research: Atmospheres}, - Month = {Jul}, Number = {13}, Pages = {6732--6745}, - Publisher = {American Geophysical Union (AGU)}, Title = {Toward the Improvement of Subseasonal Prediction in the National Centers for Environmental Prediction Global Ensemble Forecast System}, - Url = {http://dx.doi.org/10.1029/2018JD028506}, Volume = {123}, Year = {2018}, Bdsk-Url-1 = {http://dx.doi.org/10.1029/2018JD028506}, @@ -1779,12 +1763,12 @@ @article{zeng_and_dickinson_1998 @conference{zheng_et_al_2009, Address = {Omaha, Nebraska}, Author = {W. Zheng and H. Wei and J. Meng and M. Ek and K. Mitchell and J. Derber and X. Zeng and Z. Wang}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBWLi4vLi4vLi4vLi4vLi4vRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGZPEQIgAAAAAAIgAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADT4djXSCsAAANl5rUfSW1wcm92ZW1lbnRfb2ZfTGFuZCMzNjVGRjBGLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2X/D9aQ780AAAAAAAAAAAAFAAMAAAkgAAAAAAAAAAAAAAAAAAAACE5PQUhfTFNNABAACAAA0+ItNwAAABEACAAA1pFSPQAAAAEAEANl5rUAD8YgAA/GDwAGL94AAgBRTWFjaW50b3NoIEhEOlVzZXJzOgBtYW4uemhhbmc6AERlc2t0b3A6AE5PQUhfTFNNOgBJbXByb3ZlbWVudF9vZl9MYW5kIzM2NUZGMEYucGRmAAAOAG4ANgBJAG0AcAByAG8AdgBlAG0AZQBuAHQAXwBvAGYAXwBMAGEAbgBkAF8AUwB1AHIAZgBhAGMAZQBfAFMAawBpAG4AXwBUAGUAbQBwAGUAcgBhAHQAdQByAGUAXwBpAG4AXwBOAEMALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAFdVc2Vycy9tYW4uemhhbmcvRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGYAABMAAS8AABUAAgAQ//8AAAAIAA0AGgAkAH0AAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACoQ==}, Date-Added = {2018-01-26 22:19:06 +0000}, Date-Modified = {2018-01-29 23:51:37 +0000}, Organization = {The 23rd Conference on Weather Analysis and Forecasting (WAF)/19th Conference on Numerical Weather Prediction(NWP)}, Title = {Improvement of land surface skin temperature in NCEP Operational NWP models and its impact on satellite Data Assimilation}, - Year = {2009}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBWLi4vLi4vLi4vLi4vLi4vRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGZPEQIgAAAAAAIgAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADT4djXSCsAAANl5rUfSW1wcm92ZW1lbnRfb2ZfTGFuZCMzNjVGRjBGLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2X/D9aQ780AAAAAAAAAAAAFAAMAAAkgAAAAAAAAAAAAAAAAAAAACE5PQUhfTFNNABAACAAA0+ItNwAAABEACAAA1pFSPQAAAAEAEANl5rUAD8YgAA/GDwAGL94AAgBRTWFjaW50b3NoIEhEOlVzZXJzOgBtYW4uemhhbmc6AERlc2t0b3A6AE5PQUhfTFNNOgBJbXByb3ZlbWVudF9vZl9MYW5kIzM2NUZGMEYucGRmAAAOAG4ANgBJAG0AcAByAG8AdgBlAG0AZQBuAHQAXwBvAGYAXwBMAGEAbgBkAF8AUwB1AHIAZgBhAGMAZQBfAFMAawBpAG4AXwBUAGUAbQBwAGUAcgBhAHQAdQByAGUAXwBpAG4AXwBOAEMALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAFdVc2Vycy9tYW4uemhhbmcvRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGYAABMAAS8AABUAAgAQ//8AAAAIAA0AGgAkAH0AAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACoQ==}} + Year = {2009}} @article{chen_et_al_1997, Author = {F. Chen and Z. Janjic and K. Mitchell}, @@ -2023,6 +2007,7 @@ @article{iacono_et_al_2008 @article{grant_2001, Abstract = {A closure for the fluxes of mass, heat, and moisture at cloud base in the cumulus-capped boundary layer is developed. The cloud-base mass flux is obtained from a simplifed turbulence kinetic energy (TKE) budget for the sub-cloud layer, in which cumulus convection is assumed to be associated with a transport of TKE from the sub-cloud layer to the cloud layer.The heat and moisture fluxes are obtained from a jump model based on the virtual-potential-temperature equation. A key part of this parametrization is the parametrization of the virtual-temperature flux at the top of the transition zone between the sub-cloud and cloud layers.It is argued that pressure fluctuations must be responsible for the transport of TKE from the cloud layer to the sub-cloud layer.}, Author = {A. L. M. Grant}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JhbnQvMjAwMS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoiV4IMjAwMS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARgJuNOHLk4AAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyYW50AAAQAAgAANHneLIAAAARAAgAANOHgq4AAAABABgAKIleAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyYW50OgAyMDAxLnBkZgAADgASAAgAMgAwADAAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmFudC8yMDAxLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-06-15 22:11:22 +0000}, Date-Modified = {2018-07-06 19:02:34 +0000}, Doi = {10.1002/qj.49712757209}, @@ -2036,13 +2021,13 @@ @article{grant_2001 Url = {http://dx.doi.org/10.1002/qj.49712757209}, Volume = {127}, Year = {2001}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JhbnQvMjAwMS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoiV4IMjAwMS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARgJuNOHLk4AAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyYW50AAAQAAgAANHneLIAAAARAAgAANOHgq4AAAABABgAKIleAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyYW50OgAyMDAxLnBkZgAADgASAAgAMgAwADAAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmFudC8yMDAxLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1002/qj.49712757209}} @article{zhang_and_wu_2003, Abstract = {Abstract This study uses a 2D cloud-resolving model to investigate the vertical transport of horizontal momentum and to understand the role of a convection-generated perturbation pressure field in the momentum transport by convective systems during part of the Tropical Ocean and Global Atmosphere Coupled Ocean?Atmosphere Response Experiment (TOGA COARE) Intensive Observation Period. It shows that convective updrafts transport a significant amount of momentum vertically. This transport is downgradient in the easterly wind regime, but upgradient during a westerly wind burst. The differences in convective momentum transport between easterly and westerly wind regimes are examined. The perturbation pressure gradient accounts for an important part of the apparent momentum source. In general it is opposite in sign to the product of cloud mass flux and the vertical wind shear, with smaller magnitude. Examination of the dynamic forcing to the pressure field demonstrates that the linear forcing representing the interaction between the convective updrafts and the large-scale wind shear is the dominant term, while the nonlinear forcing is of secondary importance. Thus, parameterization schemes taking into account the linear interaction between the convective updrafts and the large-scale wind shear can capture the essential features of the perturbation pressure field. The parameterization scheme for momentum transport by Zhang and Cho is evaluated using the model simulation data. The parameterized pressure gradient force using the scheme is in excellent agreement with the simulated one. The parameterized apparent momentum source is also in good agreement with the model simulation. Other parameterization methods for the pressure gradient are also discussed.}, Annote = {doi: 10.1175/1520-0469(2003)060<1120:CMTAPP>2.0.CO;2}, Author = {Zhang, Guang J. and Wu, Xiaoqing}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {2003/05/01}, Date-Added = {2016-06-14 23:39:50 +0000}, @@ -2061,13 +2046,13 @@ @article{zhang_and_wu_2003 Url = {http://dx.doi.org/10.1175/1520-0469(2003)060<1120:CMTAPP>2.0.CO;2}, Volume = {60}, Year = {2003}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(2003)060%3C1120:CMTAPP%3E2.0.CO;2}} @article{fritsch_and_chappell_1980, Abstract = {Abstract A parameterization formulation for incorporating the effects of midlatitude deep convection into mesoscale-numerical models is presented. The formulation is based on the hypothesis that the buoyant energy available to a parcel, in combination with a prescribed period of time for the convection to remove that energy, can be used to regulate the amount of convection in a mesoscale numerical model grid element. Individual clouds are represented as entraining moist updraft and downdraft plumes. The fraction of updraft condensate evaporated in moist downdrafts is determined from an empirical relationship between the vertical shear of the horizontal wind and precipitation efficiency. Vertical transports of horizontal momentum and warming by compensating subsidence are included in the parameterization. Since updraft and downdraft areas are sometimes a substantial fraction of mesoscale model grid-element areas, grid-point temperatures (adjusted for convection) are an area-weighted mean of updraft, downdraft and environmental temperatures.}, Annote = {doi: 10.1175/1520-0469(1980)037<1722:NPOCDM>2.0.CO;2}, Author = {Fritsch, J. M. and Chappell, C. F.}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1980/08/01}, Date = {1980/08/01}, @@ -2088,12 +2073,12 @@ @article{fritsch_and_chappell_1980 Volume = {37}, Year = {1980}, Year1 = {1980}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1980)037%3C1722:NPOCDM%3E2.0.CO;2}} @article{bechtold_et_al_2008, Abstract = {Advances in simulating atmospheric variability with the ECMWF model are presented that stem from revisions of the convection and diffusion parametrizations. The revisions concern in particular the introduction of a variable convective adjustment time-scale, a convective entrainment rate proportional to the environmental relative humidity, as well as free tropospheric diffusion coefficients for heat and momentum based on Monin--Obukhov functional dependencies.The forecasting system is evaluated against analyses and observations using high-resolution medium-range deterministic and ensemble forecasts, monthly and seasonal integrations, and decadal integrations with coupled atmosphere-ocean models. The results show a significantly higher and more realistic level of model activity in terms of the amplitude of tropical and extratropical mesoscale, synoptic and planetary perturbations. Importantly, with the higher variability and reduced bias not only the probabilistic scores are improved, but also the midlatitude deterministic scores in the short and medium ranges. Furthermore, for the first time the model is able to represent a realistic spectrum of convectively coupled equatorial Kelvin and Rossby waves, and maintains a realistic amplitude of the Madden--Julian oscillation (MJO) during monthly forecasts. However, the propagation speed of the MJO is slower than observed. The higher tropical tropospheric wave activity also results in better stratospheric temperatures and winds through the deposition of momentum.The partitioning between convective and resolved precipitation is unaffected by the model changes with roughly 62% of the total global precipitation being of the convective type. Finally, the changes in convection and diffusion parametrizations resulted in a larger spread of the ensemble forecasts, which allowed the amplitude of the initial perturbations in the ensemble prediction system to decrease by 30%. Copyright {\copyright} 2008 Royal Meteorological Society}, Author = {Bechtold, Peter and K{\"o}hler, Martin and Jung, Thomas and Doblas-Reyes, Francisco and Leutbecher, Martin and Rodwell, Mark J. and Vitart, Frederic and Balsamo, Gianpaolo}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-06-14 23:11:58 +0000}, Date-Modified = {2016-06-14 23:11:58 +0000}, Doi = {10.1002/qj.289}, @@ -2107,12 +2092,12 @@ @article{bechtold_et_al_2008 Url = {http://dx.doi.org/10.1002/qj.289}, Volume = {134}, Year = {2008}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://dx.doi.org/10.1002/qj.289}} @article{han_and_pan_2011, Annote = {doi: 10.1175/WAF-D-10-05038.1}, Author = {Han, Jongil and Pan, Hua-Lu}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Weather and Forecasting}, Da = {2011/08/01}, Date = {2011/08/01}, @@ -2133,22 +2118,22 @@ @article{han_and_pan_2011 Volume = {26}, Year = {2011}, Year1 = {2011}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/WAF-D-10-05038.1}} @article{pan_and_wu_1995, Author = {Pan, H. -L. and W.-S. Wu}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Date-Added = {2016-06-14 23:06:41 +0000}, Date-Modified = {2016-06-14 23:06:41 +0000}, Journal = {NMC Office Note, No. 409}, Pages = {40pp}, Title = {Implementing a Mass Flux Convection Parameterization Package for the NMC Medium-Range Forecast Model}, - Year = {1995}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}} + Year = {1995}} @article{grell_1993, Annote = {doi: 10.1175/1520-0493(1993)121<0764:PEOAUB>2.0.CO;2}, Author = {Grell, Georg A.}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Monthly Weather Review}, Da = {1993/03/01}, Date = {1993/03/01}, @@ -2169,11 +2154,11 @@ @article{grell_1993 Volume = {121}, Year = {1993}, Year1 = {1993}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1993)121%3C0764:PEOAUB%3E2.0.CO;2}} @article{arakawa_and_schubert_1974, Author = {Arakawa, A and Schubert, WH}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Date-Added = {2016-06-14 23:04:30 +0000}, Date-Modified = {2018-07-18 19:00:17 +0000}, Isi = {A1974S778800004}, @@ -2186,7 +2171,6 @@ @article{arakawa_and_schubert_1974 Title = {Interaction of a cumulus cloud ensemble with the large-scale environment, Part I}, Volume = {31}, Year = {1974}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1974S778800004}} @article{harshvardhan_et_al_1989, @@ -2420,6 +2404,7 @@ @article{akmaev_1991 @article{siebesma_et_al_2007, Abstract = {A better conceptual understanding and more realistic parameterizations of convective boundary layers in climate and weather prediction models have been major challenges in meteorological research. In particular, parameterizations of the dry convective boundary layer, in spite of the absence of water phase-changes and its consequent simplicity as compared to moist convection, typically suffer from problems in attempting to represent realistically the boundary layer growth and what is often referred to as countergradient fluxes. The eddy-diffusivity (ED) approach has been relatively successful in representing some characteristics of neutral boundary layers and surface layers in general. The mass-flux (MF) approach, on the other hand, has been used for the parameterization of shallow and deep moist convection. In this paper, a new approach that relies on a combination of the ED and MF parameterizations (EDMF) is proposed for the dry convective boundary layer. It is shown that the EDMF approach follows naturally from a decomposition of the turbulent fluxes into 1) a part that includes strong organized updrafts, and 2) a remaining turbulent field. At the basis of the EDMF approach is the concept that nonlocal subgrid transport due to the strong updrafts is taken into account by the MF approach, while the remaining transport is taken into account by an ED closure. Large-eddy simulation (LES) results of the dry convective boundary layer are used to support the theoretical framework of this new approach and to determine the parameters of the EDMF model. The performance of the new formulation is evaluated against LES results, and it is shown that the EDMF closure is able to reproduce the main properties of dry convective boundary layers in a realistic manner. Furthermore, it will be shown that this approach has strong advantages over the more traditional countergradient approach, especially in the entrainment layer. As a result, this EDMF approach opens the way to parameterize the clear and cumulus-topped boundary layer in a simple and unified way.}, Author = {Siebesma, A. Pier and Soares, Pedro M. M. and Teixeira, Joao}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {DOI 10.1175/JAS3888.1}, @@ -2433,12 +2418,12 @@ @article{siebesma_et_al_2007 Title = {A combined eddy-diffusivity mass-flux approach for the convective boundary layer}, Volume = {64}, Year = {2007}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000245742600011}} @article{soares_et_al_2004, Abstract = {Recently, a new consistent way of parametrizing simultaneously local and non-local turbulent transport for the convective atmospheric boundary layer has been proposed and tested for the clear boundary layer. This approach assumes that in the convective boundary layer the subgrid-scale fluxes result from two different mixing scales: small eddies, that are parametrized by an eddy-diffusivity approach, and thermals, which are represented by a mass-flux contribution. Since the interaction between the cloud layer and the underlying sub-cloud layer predominantly takes place through strong updraughts, this approach offers an interesting avenue of establishing a unified description of the turbulent transport in the cumulus-topped boundary layer. This paper explores the possibility of such a new approach for the cumulus-topped boundary layer. In the sub-cloud and cloud layers, the mass-flux term represents the effect of strong updraughts. These are modelled by a simple entraining parcel, which determines the mean properties of the strong updraughts, the boundary-layer height, the lifting condensation level and cloud top. The residual smaller-scale turbulent transport is parametrized with an eddy-diffusivity approach that uses a turbulent kinetic energy closure. The new scheme is implemented and tested in the research model MesoNH. Copyright {\copyright} 2004 Royal Meteorological Society}, Author = {Soares, P. M. M. and Miranda, P. M. A. and Siebesma, A. P. and Teixeira, J.}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1256/qj.03.223}, @@ -2452,11 +2437,11 @@ @article{soares_et_al_2004 Url = {http://dx.doi.org/10.1256/qj.03.223}, Volume = {130}, Year = {2004}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Bdsk-Url-1 = {http://dx.doi.org/10.1256/qj.03.223}} @article{troen_and_mahrt_1986, Author = {Troen, IB and Mahrt, L.}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1007/BF00122760}, @@ -2470,13 +2455,13 @@ @article{troen_and_mahrt_1986 Url = {http://dx.doi.org/10.1007/BF00122760}, Volume = {37}, Year = {1986}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1007/BF00122760}} @article{macvean_and_mason_1990, Abstract = {Abstract In a recent paper, Kuo and Schubert demonstrated the lack of observational support for the relevance of the criterion for cloud-top entrainment instability proposed by Randall and by Deardorff. Here we derive a new criterion, based on a model of the instability as resulting from the energy released close to cloud top, by Mixing between saturated boundary-layer air and unsaturated air from above the capping inversion. The condition is derived by considering the net conversion from potential to kinetic energy in a system consisting of two layers of fluid straddling cloud-top, when a small amount of mixing occurs between these layers. This contrasts with previous analyses, which only considered the change in buoyancy of the cloud layer when unsaturated air is mixed into it. In its most general form, this new criterion depends on the ratio of the depths of the layers involved in the mixing. It is argued that, for a self-sustaining instability, there must be a net release of kinetic energy on the same depth and time scales as the entrainment process itself. There are two plausible ways in which this requirement may be satisfied. Either one takes the depths of the layers involved in the mixing to each be comparable to the vertical scale of the entrainment process, which is typically of order tens of meters or less, or alternatively, one must allow for the efficiency with which energy released by mixing through a much deeper lower layer becomes available to initiate further entrainment. In both cases the same criterion for instability results. This criterion is much more restrictive than that proposed by Randall and by Deardorff; furthermore, the observational data is then consistent with the predictions of the current theory. Further analysis provides estimates of the turbulent fluxes associated with cloud-top entrainment instability. This analysis effectively constitutes an energetically consistent turbulence closure for models of boundary layers with cloud. The implications for such numerical models are discussed. Comparisons are also made with other possible criteria for cloud-top entrainment instability which have recently been suggested.}, Annote = {doi: 10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Author = {MacVean, M. K. and Mason, P. J.}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1990/04/01}, Date-Added = {2016-05-20 17:16:05 +0000}, @@ -2495,11 +2480,11 @@ @article{macvean_and_mason_1990 Url = {http://dx.doi.org/10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Volume = {47}, Year = {1990}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1990)047%3C1012:CTEITS%3E2.0.CO;2}} @article{louis_1979, Author = {Louis, JF}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:15:52 +0000}, Date-Modified = {2016-05-20 17:15:52 +0000}, Isi = {A1979HT69700004}, @@ -2512,12 +2497,12 @@ @article{louis_1979 Title = {A PARAMETRIC MODEL OF VERTICAL EDDY FLUXES IN THE ATMOSPHERE}, Volume = {17}, Year = {1979}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1979HT69700004}} @article{lock_et_al_2000, Abstract = {A new boundary layer turbulent mixing scheme has been developed for use in the UKMO weather forecasting and climate prediction models. This includes a representation of nonlocal mixing (driven by both surface fluxes and cloud-top processes) in unstable layers, either coupled to or decoupled from the surface, and an explicit entrainment parameterization. The scheme is formulated in moist conserved variables so that it can treat both dry and cloudy layers. Details of the scheme and examples of its performance in single-column model tests are presented.}, Author = {Lock, AP and Brown, AR and Bush, MR and Martin, GM and Smith, RNB}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Date-Added = {2016-05-20 17:15:36 +0000}, Date-Modified = {2016-05-20 17:15:36 +0000}, Isi = {000089461100008}, @@ -2530,13 +2515,13 @@ @article{lock_et_al_2000 Title = {A new boundary layer mixing scheme. {P}art {I}: Scheme description and single-column model tests}, Volume = {128}, Year = {2000}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000089461100008}} @article{hong_and_pan_1996, Abstract = {Abstract In this paper, the incorporation of a simple atmospheric boundary layer diffusion scheme into the NCEP Medium-Range Forecast Model is described. A boundary layer diffusion package based on the Troen and Mahrt nonlocal diffusion concept has been tested for possible operational implementation. The results from this approach are compared with those from the local diffusion approach, which is the current operational scheme, and verified against FIFE observations during 9?10 August 1987. The comparisons between local and nonlocal approaches are extended to the forecast for a heavy rain case of 15?17 May 1995. The sensitivity of both the boundary layer development and the precipitation forecast to the tuning parameters in the nonlocal diffusion scheme is also investigated. Special attention is given to the interaction of boundary layer processes with precipitation physics. Some results of parallel runs during August 1995 are also presented.}, Annote = {doi: 10.1175/1520-0493(1996)124<2322:NBLVDI>2.0.CO;2}, Author = {Hong, Song-You and Pan, Hua-Lu}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Booktitle = {Monthly Weather Review}, Da = {1996/10/01}, Date = {1996/10/01}, @@ -2557,13 +2542,13 @@ @article{hong_and_pan_1996 Volume = {124}, Year = {1996}, Year1 = {1996}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1996)124%3C2322:NBLVDI%3E2.0.CO;2}} @article{han_and_pan_2006, Abstract = {Abstract A parameterization of the convection-induced pressure gradient force (PGF) in convective momentum transport (CMT) is tested for hurricane intensity forecasting using NCEP's operational Global Forecast System (GFS) and its nested Regional Spectral Model (RSM). In the parameterization the PGF is assumed to be proportional to the product of the cloud mass flux and vertical wind shear. Compared to control forecasts using the present operational GFS and RSM where the PGF effect in CMT is taken into account empirically, the new PGF parameterization helps increase hurricane intensity by reducing the vertical momentum exchange, giving rise to a closer comparison to the observations. In addition, the new PGF parameterization forecasts not only show more realistically organized precipitation patterns with enhanced hurricane intensity but also reduce the forecast track error. Nevertheless, the model forecasts with the new PGF parameterization still largely underpredict the observed intensity. One of the many possible reasons for the large underprediction may be the absence of hurricane initialization in the models.}, Annote = {doi: 10.1175/MWR3090.1}, Author = {Han, Jongil and Pan, Hua-Lu}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Monthly Weather Review}, Da = {2006/02/01}, Date-Added = {2016-05-20 17:11:17 +0000}, @@ -2582,11 +2567,11 @@ @article{han_and_pan_2006 Url = {http://dx.doi.org/10.1175/MWR3090.1}, Volume = {134}, Year = {2006}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/MWR3090.1}} @article{businger_et_al_1971, Author = {Businger, JA and Wyngaard, JC and Izumi, Y and Bradley, EF}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:10:50 +0000}, Date-Modified = {2018-07-18 18:58:08 +0000}, Isi = {A1971I822800004}, @@ -2599,7 +2584,6 @@ @article{businger_et_al_1971 Title = {Flux-profile relationships in the atmospheric surface layer}, Volume = {28}, Year = {1971}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1971I822800004}} @article{xu_and_randall_1996, @@ -2790,17 +2774,18 @@ @article{kim_and_arakawa_1995 @techreport{hou_et_al_2002, Author = {Y. Hou and S. Moorthi and K. Campana}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}, Date-Added = {2016-05-19 19:52:22 +0000}, Date-Modified = {2016-05-20 15:14:59 +0000}, Institution = {NCEP}, Number = {441}, Title = {Parameterization of Solar Radiation Transfer}, Type = {office note}, - Year = {2002}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}} + Year = {2002}} @article{hu_and_stamnes_1993, Author = {Y.X. Hu and K. Stamnes}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}, Date-Added = {2016-05-19 19:31:56 +0000}, Date-Modified = {2016-05-20 15:13:12 +0000}, Journal = {J. Climate}, @@ -2808,5 +2793,4 @@ @article{hu_and_stamnes_1993 Pages = {728-742}, Title = {An accurate parameterization of the radiative properties of water clouds suitable for use in climate models}, Volume = {6}, - Year = {1993}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}} + Year = {1993}} diff --git a/physics/docs/pdftxt/CPT_CSAW.txt b/physics/docs/pdftxt/CPT_CSAW.txt index 09b81fa10..781c9937a 100644 --- a/physics/docs/pdftxt/CPT_CSAW.txt +++ b/physics/docs/pdftxt/CPT_CSAW.txt @@ -1,5 +1,5 @@ /** -\page CSAW_scheme CPT Scale-Aware Chikira-Sugiyama Scale-aware Convection Scheme with Arakawa-Wu Extension +\page CSAW_scheme Scale-Aware Chikira-Sugiyama Scale-aware Convection Scheme with Arakawa-Wu Extension \section cs_descrip Description Chikira-Sugiyama cumulus scheme (Chikira and Sugiyama (2010) \cite Chikira_2010) with prognostic closure and diff --git a/physics/docs/pdftxt/CPT_MG3.txt b/physics/docs/pdftxt/CPT_MG3.txt index 04d5d0a33..c6d169dc1 100644 --- a/physics/docs/pdftxt/CPT_MG3.txt +++ b/physics/docs/pdftxt/CPT_MG3.txt @@ -1,9 +1,8 @@ /** -\page CPT_MG3 CPT MG3 Cloud Microphysics Scheme +\page CPT_MG3 Morrison-Gettelman Cloud Microphysics Scheme \section des_MG3_cloud Description -MG3 microphysics (MP) scheme is a six-category double momentum bulk scheme. It forecasts mass of ten -hydrometeors (cloud water, cloud ice, rain, snow and graupel) and their number concentrations in addition to mass of water vapor. -Physics processes of MG3 cloud MP are described in Figure 1. +The Morrison-Gettelman Version 3 (MG3) microphysics scheme is a six-category double momentum bulk scheme. It forecasts mass +and number concentration of five hydrometeors (cloud water, cloud ice, rain, snow and graupel) in addition to mass of water vapor. # Morrison Gettelman Advancements - MG1: Morrison and Gettelman (2008) \cite Morrison_2008 (CESM1, CAM5) @@ -13,33 +12,28 @@ Physics processes of MG3 cloud MP are described in Figure 1. - MG2: Gettelman and Morrison (2015) \cite Gettelman_2015_1 \cite Gettelman_2015_2 (CESM2, CAM6) - Prognostic precipitation (rain and snow) - Sub-stepping and sub-column capable -- MG3: Gettelman et al. 2019 (accepted by JAMES) - - Rimed hydrometeors (graupel or hail) are added to stratiform cloud scheme for global models. - - Global climate impacts are limited to small increased in ice mass. - - High (14 km) resolution similations show local production of rimed ice (graupel) can affect regional precipitation amounts and intensity. +- MG3: Gettelman et al. 2019 \cite Gettelman_et_al_2019 + - Rimed hydrometeors (graupel or hail) are added to stratiform cloud scheme for global models + - Global climate impacts are limited to small increased in ice mass + - High (14 km) resolution simulations show local production of rimed ice (graupel) can affect regional +precipitation amounts and intensity A schematic of the MG3 scheme is shown in Figure 1. MG3 starts with MG2 \cite Gettelman_2015_1 \cite Gettelman_2015_2 and adds a series of processes (in red). One rimed hydrometeor category is added. Both mass and number are prognosed. Rimed ice has the -"character" of hail or graupel by pre-selecting density and fall speed paramters. +"character" of hail or graupel by pre-selecting density and fall speed parameters. \image html MG3_MP_diagram.png "Figure 1: A schematic of the MG3 scheme (Courtesy of A. Gettleman )" width=10cm - - Some unique attributes of MG3 cloud microphysics include: -# Consistent treatment of cloud fraction in cloud macrophysics and radiation -# Subgrid-scale microphysics --# Max-overlap and in-cloud precipitation fraction area +-# Maximum-overlap and in-cloud precipitation fraction area -# Options for subcolumn microphysics --# Options to run MG2 using the same code as MG3 --# Options to run MG1 --# Completely aerosol awareness with 1) 1) constant aerosol mixing ratio, 2) climatology IN/CCN from CAM5, 3) climatology aerosol from MERRA2 , 4) GOCART, and 5) MAM7 --# Options to call fast physics as GFDL microphysics --# Number concentration of all species forcasted and has local storage +-# Options for running with fewer species and processes, simulating MG1 and MG2 codes +-# Completely aerosol awareness with 1) constant aerosol mixing ratio, 2) climatology IN/CCN from CAM5 (default; \c cam5_4_143_NAAI_monclimo2.nc), 3) climatology aerosol from MERRA2 , 4) GOCART, and 5) MAM7 -# Sub-step semi-implicit sedimentation - - +-# Can be used along with the FV in-core saturation adjustment \section intra_mg3 Intraphysics Communication \ref arg_table_m_micro_run diff --git a/physics/docs/pdftxt/CPT_adv_suite.txt b/physics/docs/pdftxt/CPT_adv_suite.txt index fa9801e07..fb4fb8c0a 100644 --- a/physics/docs/pdftxt/CPT_adv_suite.txt +++ b/physics/docs/pdftxt/CPT_adv_suite.txt @@ -1,9 +1,9 @@ /** -\page suite3_page FV3_CPT_v0 +\page MGCSAW_page MGCSAW -\section CPT_suite_overview Overview +\section MGCSAW_suite_overview Overview -The advanced CPT physics suite uses the parameterizations in the following order: +The advanced MGCSAW physics suite uses the parameterizations in the following order: - \ref fast_sat_adj - \ref GFS_RRTMG - \ref GFS_SFCLYR @@ -25,11 +25,11 @@ The advanced CPT physics suite uses the parameterizations in the following order \section sdf_cpt_suite Suite Definition File -The advanced CPT physics suite uses the parameterizations in the following order, as defined in \c FV3_CPT : +The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c FV3_CPT : \code - + @@ -132,85 +132,89 @@ The advanced CPT physics suite uses the parameterizations in the following order \section cpt_nml_option Namelist Option \code - fhzero = 6 - h2o_phys = .true. - oz_phys = .false. - oz_phys_2015 = .true. - ldiag3d = .false. - fhcyc = 24 - use_ufo = .true. - pre_rad = .false. - crtrh = 0.95,0.95,0.90 - ncld = 2 - imp_physics = 10 - pdfcld = .false. - fhswr = 3600. - fhlwr = 3600. - ialb = 1 - iems = 1 - iaer = 111 - ico2 = 2 - isubc_sw = 2 - isubc_lw = 2 - isol = 2 - lwhtr = .true. - swhtr = .true. - cnvgwd = .true. - shal_cnv = .true. - cal_pre = .false. - redrag = .true. - dspheat = .true. - hybedmf = .true. - random_clds = .false. - trans_trac = .true. - cnvcld = .true. - imfshalcnv = 2 - imfdeepcnv = -1 - cdmbgwd = 3.5,0.25 - prslrd0 = 0. - ivegsrc = 1 - isot = 1 - debug = .false. - ras = .false. - cscnv = .true. - do_shoc = .false. - do_aw = .true. - shoc_cld = .false. - h2o_phys = .true. - shcnvcw = .false. - xkzm_h = 0.5 - xkzm_m = 0.5 - xkzm_s = 1.0 - nstf_name = 2,1,0,0 - nst_anl = .true. - psautco = 0.0008,0.0005 - prautco = 0.00015,0.00015 - microp_uniform = .false. - mg_do_ice_gmao = .true. - mg_do_liq_liu = .true. - mg_dcs = 100.00 - mg_alf = 1.2 - mg_ts_auto_ice = 500.,2000. - mg_qcvar = 0.5 - fprcp = 2 - cs_parm = 2.6,1.0,0.05e3,2.0e3,50.0,1.0,-999.,1.,0.6,0. - shoc_parm = 7000.0,1.0,4.2857143,0.7,-999.0 - iccn = .false. - aero_in = .false. - ctei_rm = 10.0,10.0 - max_lon = 8000 - max_lat = 4000 - rhcmax = 0.9999999 - effr_in = .true. - ltaerosol = .false. - lradar = .false. - cplflx = .false. - iau_delthrs = 6 - iaufhrs = 30 - iau_inc_files = '' - +&gfs_physics_nml + fhzero = 6. + ldiag3d = .true. + fhcyc = 24. + use_ufo = .true. + pre_rad = .false. + crtrh = 0.93,0.90,0.95 + ncld = 2 + imp_physics = 10 + pdfcld = .false. + fhswr = 3600. + fhlwr = 3600. + ialb = 1 + iems = 1 + IAER = 111 + ico2 = 2 + isubc_sw = 2 + isubc_lw = 2 + isol = 2 + lwhtr = .true. + swhtr = .true. + cnvgwd = .true. + shal_cnv = .true. + cal_pre = .false. + redrag = .true. + dspheat = .true. + hybedmf = .true. + satmedmf = .false. + lheatstrg = .false. + random_clds = .true. + trans_trac = .true. + cnvcld = .true. + imfshalcnv = 2 + imfdeepcnv = -1 + cdmbgwd = 3.5,0.25 + prslrd0 = 0. + ivegsrc = 1 + isot = 1 + oz_phys = .false. + oz_phys_2015 = .true. + debug = .false. + ras = .false. + cscnv = .true. + do_shoc = .false. + do_aw = .true. + shoc_cld = .false. + h2o_phys = .true. + shcnvcw = .false. + xkzm_h = 0.5 + xkzm_m = 0.5 + xkzm_s = 1.0 + nstf_name = 2,1,1,0,5 + nst_anl = .true. + ccwf = 1.0,1.0 + dlqf = 0.25,0.05 + mg_dcs = 200.0 + mg_ts_auto_ice = 180.0,900.0 + mg_qcvar = 1.0 + fprcp = 2 + pdfflag = 4 + iccn = .false. + aero_in = .false. + mg_do_graupel = .true. + mg_do_hail = .false. + do_sb_physics = .true. + mg_do_ice_gmao = .false. + mg_do_liq_liu = .true. + cs_parm = 8.0,4.0,1.0e3,3.5e3,20.0,1.0,0.0,1.0,0.6,0.0 + shoc_parm = 7000.0,1.0,2.0,0.7,-999.0 + ctei_rm = 0.60,0.23 + max_lon = 8000 + max_lat = 4000 + rhcmax = 0.9999999 + effr_in = .true. + ltaerosol = .false. + lradar = .false. + cplflx = .false. + iau_delthrs = 6 + iaufhrs = 30 + iau_inc_files = "''" +/ \endcode -- \ref gfs_physics_nml -- \ref cpt_physics_nml + + */ diff --git a/physics/docs/pdftxt/GFSv15_suite.txt b/physics/docs/pdftxt/GFSv15_suite.txt index cf7e68068..428c1c4e7 100644 --- a/physics/docs/pdftxt/GFSv15_suite.txt +++ b/physics/docs/pdftxt/GFSv15_suite.txt @@ -1,19 +1,16 @@ /** -\page suite1_page FV3_GFS_v15 +\page GFS_v15_page GFS_v15 \section gfs1_suite_overview Overview -Effective on or about Wednesday, June 12, 2019, begining with the 1200 +Effective on or about Wednesday, June 12, 2019, beginning with the 1200 Coordinated Universal Time (UTC) run, the National Centers for Environmental -Prediction (NCEP) will upgrade the Global Forecast Systems (GFS) from version 14 to 15.1. +Prediction (NCEP) will upgrade the Global Forecast Systems (GFS) from version 14 to 15. -NOAA/NWS selected the finite-volume cubed-sphere (FV3) dynamical core as the Next -Generation Global Prediction System (NGGPS). The FV3 was developed by the Geophysical -Fluid Dynamics Laboratory (GFDL) under NOAA's Office of Atmospheric Research (OAR). -The GFS version 15.1 uses the FV3 dynamical core and improved physics parameterizations. Compared -to version 14, the GFS version 15.1 uses the same physics package except for: -- Replacement of \ref GFS_ZHAOC with the more advanced \ref GFDL_cloud -- Updated paramterization of ozone photochemistry with additional production and loss terms +GFS v15 will use the Finite-Volume Cubed-Sphere (FV3) dynamical core +and a revised physics suite when compared to GFS v14. +- Replacement of the Zhao-Carr microphysics with the more advanced \ref GFDL_cloud +- Updated parameterization of ozone photochemistry with additional production and loss terms - Newly introduced parameterization of middle atmospheric water vapor photochemistry (\ref GFS_H2OPHYS) - Revised bare soil evaporation scheme - Modified convective parameterization scheme to reduce excessive cloud top cooling @@ -141,99 +138,110 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i \section gfs15_nml_opt_des Namelist Option \code - fhzero = 6 - h2o_phys = .true. - oz_phys = .false. - oz_phys_2015 = .true. - ldiag3d = .false. - fhcyc = 24 - use_ufo = .true. - pre_rad = .false. - ncld = 5 - imp_physics = 11 - pdfcld = .false. - fhswr = 3600. - fhlwr = 3600. - ialb = 1 - iems = 1 - iaer = 111 - ico2 = 2 - isubc_sw = 2 - isubc_lw = 2 - isol = 2 - lwhtr = .true. - swhtr = .true. - cnvgwd = .true. - shal_cnv = .true. - cal_pre = .false. - redrag = .true. - dspheat = .true. - hybedmf = .true. - random_clds = .false. - trans_trac = .true. - cnvcld = .true. - imfshalcnv = 2 - imfdeepcnv = 2 - cdmbgwd = 3.5,0.25 - prslrd0 = 0. - ivegsrc = 1 - isot = 1 - debug = .false. - nstf_name = 2,0,0,0,0 - nst_anl = .true. - psautco = 0.0008,0.0005 - prautco = 0.00015,0.00015 -\endcode -check \ref gfs_physics_nml for description +&gfs_physics_nml + fhzero = 6. + ldiag3d = .true. + fhcyc = 24. + nst_anl = .true. + use_ufo = .true. + pre_rad = .false. + ncld = 5 + imp_physics = 11 + pdfcld = .false. + fhswr = 3600. + fhlwr = 3600. + ialb = 1 + iems = 1 + IAER = 111 + ico2 = 2 + isubc_sw = 2 + isubc_lw = 2 + isol = 2 + lwhtr = .true. + swhtr = .true. + cnvgwd = .true. + shal_cnv = .true. + cal_pre = .false. + redrag = .true. + dspheat = .true. + hybedmf = .true. + satmedmf = .false. + shinhong = .false. + do_ysu = .false. + lheatstrg = .false. + lgfdlmprad = .false. + effr_in = .false. + random_clds = .false. + trans_trac = .false. + cnvcld = .true. + imfshalcnv = 2 + imfdeepcnv = 2 + cdmbgwd = 3.5,0.25 + prslrd0 = 0. + ivegsrc = 1 + isot = 1 + debug = .false. + oz_phys = .false. + oz_phys_2015 = .true. + h2o_phys = .true. + nstf_name = 2,1,1,0,5 + xkzminv = 0.3 + xkzm_m = 1.0 + xkzm_h = 1.0 + do_sppt = .false. + do_shum = .false. + do_skeb = .false. + do_sfcperts = .false. +/ -\code - sedi_transport = .true. - do_sedi_heat = .false. - rad_snow = .true. - rad_graupel = .true. - rad_rain = .true. - const_vi = .F. - const_vs = .F. - const_vg = .F. - const_vr = .F. - vi_max = 1. - vs_max = 2. - vg_max = 12. - vr_max = 12. - qi_lim = 1. - prog_ccn = .false. - do_qa = .true. - fast_sat_adj = .true. - tau_l2v = 225. - tau_v2l = 150. - tau_g2v = 900. - rthresh = 10.e-6 - dw_land = 0.16 - dw_ocean = 0.10 - ql_gen = 1.0e-3 - ql_mlt = 1.0e-3 - qi0_crt = 8.0E-5 - qs0_crt = 1.0e-3 - tau_i2s = 1000. - c_psaci = 0.05 - c_pgacs = 0.01 - rh_inc = 0.30 - rh_inr = 0.30 - rh_ins = 0.30 - ccn_l = 300. - ccn_o = 100. - c_paut = 0.5 - c_cracw = 0.8 - use_ppm = .false. - use_ccn = .true. - mono_prof = .true. - z_slope_liq = .true. - z_slope_ice = .true. - de_ice = .false. - fix_negative = .true. - icloud_f = 1 - mp_time = 150. +&gfdl_cloud_microphysics_nml + sedi_transport = .true. + do_sedi_heat = .false. + rad_snow = .true. + rad_graupel = .true. + rad_rain = .true. + const_vi = .F. + const_vs = .F. + const_vg = .F. + const_vr = .F. + vi_max = 1. + vs_max = 2. + vg_max = 12. + vr_max = 12. + qi_lim = 1. + prog_ccn = .false. + do_qa = .false. + fast_sat_adj = .false. + tau_l2v = 225. + tau_v2l = 150. + tau_g2v = 900. + rthresh = 10.e-6 + dw_land = 0.16 + dw_ocean = 0.10 + ql_gen = 1.0e-3 + ql_mlt = 1.0e-3 + qi0_crt = 8.0E-5 + qs0_crt = 1.0e-3 + tau_i2s = 1000. + c_psaci = 0.05 + c_pgacs = 0.01 + rh_inc = 0.30 + rh_inr = 0.30 + rh_ins = 0.30 + ccn_l = 300. + ccn_o = 100. + c_paut = 0.5 + c_cracw = 0.8 + use_ppm = .false. + use_ccn = .true. + mono_prof = .true. + z_slope_liq = .true. + z_slope_ice = .true. + de_ice = .false. + fix_negative = .true. + icloud_f = 1 + mp_time = 150. +/ \endcode -check \ref gfdl_cloud_microphysics_nml for description */ diff --git a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt index 3b0868cec..cbcf6d849 100644 --- a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt +++ b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt @@ -1,5 +1,5 @@ /** -\page suite2_page FV3_GFS_v15plus +\page GFS_v15plus_page GFS_v15plus \section gfs2p_suite_overview Overview @@ -128,100 +128,110 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin \section gfs15p_nml_opt_des Namelist Option \code - fhzero = 6 - h2o_phys = .true. - oz_phys = .false. - oz_phys_2015 = .true. - ldiag3d = .false. - fhcyc = 24 - use_ufo = .true. - pre_rad = .false. - ncld = 5 - imp_physics = 11 - pdfcld = .false. - fhswr = 3600. - fhlwr = 3600. - ialb = 1 - iems = 1 - iaer = 111 - ico2 = 2 - isubc_sw = 2 - isubc_lw = 2 - isol = 2 - lwhtr = .true. - swhtr = .true. - cnvgwd = .true. - shal_cnv = .true. - cal_pre = .false. - redrag = .true. - dspheat = .true. - hybedmf = .false. - satmedmf = .true. - random_clds = .false. - trans_trac = .true. - cnvcld = .true. - imfshalcnv = 2 - imfdeepcnv = 2 - cdmbgwd = 3.5,0.25 - prslrd0 = 0. - ivegsrc = 1 - isot = 1 - debug = .false. - nstf_name = 2,0,0,0,0 - nst_anl = .true. - psautco = 0.0008,0.0005 - prautco = 0.00015,0.00015 -\endcode -check \ref gfs_physics_nml for description +&gfs_physics_nml + fhzero = 6. + ldiag3d = .true. + fhcyc = 24. + nst_anl = .true. + use_ufo = .true. + pre_rad = .false. + ncld = 5 + imp_physics = 11 + pdfcld = .false. + fhswr = 3600. + fhlwr = 3600. + ialb = 1 + iems = 1 + IAER = 111 + ico2 = 2 + isubc_sw = 2 + isubc_lw = 2 + isol = 2 + lwhtr = .true. + swhtr = .true. + cnvgwd = .true. + shal_cnv = .true. + cal_pre = .false. + redrag = .true. + dspheat = .true. + hybedmf = .false. + satmedmf = .true. + shinhong = .false. + do_ysu = .false. + lheatstrg = .false. + lgfdlmprad = .false. + effr_in = .false. + random_clds = .false. + trans_trac = .false. + cnvcld = .true. + imfshalcnv = 2 + imfdeepcnv = 2 + cdmbgwd = 3.5,0.25 + prslrd0 = 0. + ivegsrc = 1 + isot = 1 + debug = .false. + oz_phys = .false. + oz_phys_2015 = .true. + h2o_phys = .true. + nstf_name = 2,1,1,0,5 + xkzminv = 0.3 + xkzm_m = 1.0 + xkzm_h = 1.0 + do_sppt = .false. + do_shum = .false. + do_skeb = .false. + do_sfcperts = .false. +/ -\code - sedi_transport = .true. - do_sedi_heat = .false. - rad_snow = .true. - rad_graupel = .true. - rad_rain = .true. - const_vi = .F. - const_vs = .F. - const_vg = .F. - const_vr = .F. - vi_max = 1. - vs_max = 2. - vg_max = 12. - vr_max = 12. - qi_lim = 1. - prog_ccn = .false. - do_qa = .true. - fast_sat_adj = .true. - tau_l2v = 225. - tau_v2l = 150. - tau_g2v = 900. - rthresh = 10.e-6 - dw_land = 0.16 - dw_ocean = 0.10 - ql_gen = 1.0e-3 - ql_mlt = 1.0e-3 - qi0_crt = 8.0E-5 - qs0_crt = 1.0e-3 - tau_i2s = 1000. - c_psaci = 0.05 - c_pgacs = 0.01 - rh_inc = 0.30 - rh_inr = 0.30 - rh_ins = 0.30 - ccn_l = 300. - ccn_o = 100. - c_paut = 0.5 - c_cracw = 0.8 - use_ppm = .false. - use_ccn = .true. - mono_prof = .true. - z_slope_liq = .true. - z_slope_ice = .true. - de_ice = .false. - fix_negative = .true. - icloud_f = 1 - mp_time = 150. +&gfdl_cloud_microphysics_nml + sedi_transport = .true. + do_sedi_heat = .false. + rad_snow = .true. + rad_graupel = .true. + rad_rain = .true. + const_vi = .F. + const_vs = .F. + const_vg = .F. + const_vr = .F. + vi_max = 1. + vs_max = 2. + vg_max = 12. + vr_max = 12. + qi_lim = 1. + prog_ccn = .false. + do_qa = .false. + fast_sat_adj = .false. + tau_l2v = 225. + tau_v2l = 150. + tau_g2v = 900. + rthresh = 10.e-6 + dw_land = 0.16 + dw_ocean = 0.10 + ql_gen = 1.0e-3 + ql_mlt = 1.0e-3 + qi0_crt = 8.0E-5 + qs0_crt = 1.0e-3 + tau_i2s = 1000. + c_psaci = 0.05 + c_pgacs = 0.01 + rh_inc = 0.30 + rh_inr = 0.30 + rh_ins = 0.30 + ccn_l = 300. + ccn_o = 100. + c_paut = 0.5 + c_cracw = 0.8 + use_ppm = .false. + use_ccn = .true. + mono_prof = .true. + z_slope_liq = .true. + z_slope_ice = .true. + de_ice = .false. + fix_negative = .true. + icloud_f = 1 + mp_time = 150. +/ \endcode -check \ref gfdl_cloud_microphysics_nml for description */ diff --git a/physics/docs/pdftxt/GSD_adv_suite.txt b/physics/docs/pdftxt/GSD_adv_suite.txt index 7850c8631..3d1b79f1d 100644 --- a/physics/docs/pdftxt/GSD_adv_suite.txt +++ b/physics/docs/pdftxt/GSD_adv_suite.txt @@ -1,5 +1,5 @@ /** -\page suite4_page FV3_GSD_v0 +\page GSD_v0_page GSD_v0 \section gsd_suite_overview Overview @@ -138,72 +138,71 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order \section gsd_nml_option Namelist Option \code - fhzero = 6 - h2o_phys = .true. - oz_phys = .false. - oz_phys_2015 = .true. - ldiag3d = .false. - fhcyc = 24 - use_ufo = .true. - pre_rad = .false. - ncld = 5 - imp_physics = 8 - ltaerosol = .true. - lradar = .false. - pdfcld = .false. - fhswr = 3600. - fhlwr = 3600. - ialb = 1 - iems = 1 - iaer = 111 - ico2 = 2 - isubc_sw = 2 - isubc_lw = 2 - isol = 2 - lwhtr = .true. - swhtr = .true. - cnvgwd = .true. - shal_cnv = .true. - cal_pre = .false. - redrag = .true. - dspheat = .true. - hybedmf = .false. - satmedmf = .false. - do_mynnedmf = .true. - do_mynnsfclay = .false. - random_clds = .false. - trans_trac = .true. - cnvcld = .true. - imfshalcnv = 3 - imfdeepcnv = 3 - force_lmfshal = .true. - lmfshal = .false. - force_lmfdeep2 = .false. - cdmbgwd = 3.5,0.25 - prslrd0 = 0. - ivegsrc = 1 - isot = 1 - debug = .false. - oz_phys = .false. - oz_phys_2015 = .true. - nstf_name = 2,0,0,0,0 - nst_anl = .true. - psautco = 0.0008,0.0005 - prautco = 0.00015,0.00015 - do_sppt = .false. - do_shum = .false. - do_skeb = .false. - do_sfcperts = .false. - lsm = 2 - lsoil_lsm = 9 - icloud_bl = 1 - bl_mynn_tkeadvect = .true. - bl_mynn_edmf = 1 - bl_mynn_edmf_mom = 1 +&gfs_physics_nml + fhzero = 6. + h2o_phys = .true. + ldiag3d = .true. + fhcyc = 0. + nst_anl = .true. + use_ufo = .true. + pre_rad = .false. + ncld = 5 + imp_physics = 8 + ltaerosol = .true. + lradar = .true. + ttendlim = -999. + make_number_concentrations = .true. + pdfcld = .false. + fhswr = 3600. + fhlwr = 3600. + ialb = 1 + iems = 1 + iaer = 111 + ico2 = 2 + isubc_sw = 2 + isubc_lw = 2 + isol = 2 + lwhtr = .true. + swhtr = .true. + cnvgwd = .true. + shal_cnv = .true. + cal_pre = .false. + redrag = .true. + dspheat = .true. + hybedmf = .false. + satmedmf = .false. + lheatstrg = .false. + do_mynnedmf = .true. + do_mynnsfclay = .false. + random_clds = .false. + trans_trac = .true. + cnvcld = .true. + imfshalcnv = 3 + imfdeepcnv = 3 + cdmbgwd = 3.5,0.25 + prslrd0 = 0. + ivegsrc = 1 + isot = 1 + debug = .false. + oz_phys = .false. + oz_phys_2015 = .true. + nstf_name = 2,1,1,0,5 + cplflx = .false. + iau_delthrs = 6 + iaufhrs = 30 + iau_inc_files = "''" + do_sppt = .false. + do_shum = .false. + do_skeb = .false. + do_sfcperts = .false. + lsm = 2 + lsoil_lsm = 9 + icloud_bl = 1 + bl_mynn_tkeadvect = .true. + bl_mynn_edmf = 1 + bl_mynn_edmf_mom = 1 +/ \endcode -Check NML option description at: -- \ref gfs_physics_nml -- \ref gsd_hrrr_nml */ diff --git a/physics/docs/pdftxt/all_shemes_list.txt b/physics/docs/pdftxt/all_shemes_list.txt index 97f5fbb22..3d57b41ea 100644 --- a/physics/docs/pdftxt/all_shemes_list.txt +++ b/physics/docs/pdftxt/all_shemes_list.txt @@ -11,18 +11,18 @@ parameterizations in suites. - Radiation: - \subpage GFS_RRTMG -- PBL and turbulence: +- PBL and Turbulence: - \subpage GFS_HEDMF - \subpage GFS_SATMEDMF - \subpage GSD_MYNNEDMF -- Land surface model: +- Land Surface Model: - \subpage GFS_NOAH - \subpage surf_pert - \subpage GSD_RUCLSM -# Cumulus parameterizations: - - GFS Simplified Arakawa Schubert (SAS) +- Cumulus Parameterizations: + - GFS Scale-Aware Arakawa Schubert (SAS) Scheme - \subpage GFS_SAMFdeep - \subpage GFS_SAMFshal - \subpage CSAW_scheme @@ -42,7 +42,6 @@ parameterizations in suites. - Ozone: - \subpage GFS_OZPHYS - - \ref GFS_ozphys - \ref GFS_ozphys_2015 - Water Vapor Photochemical Production and Loss: @@ -52,8 +51,7 @@ parameterizations in suites. - \subpage GFS_GWDPS - \subpage GFS_GWDC - -- Surface layer/Sea Ice/NSST: +- Surface Layer and Simplified Ocean and Sea Ice Representation: - \subpage GFS_SFCLYR - \subpage GFS_NSST - \subpage GFS_SFCSICE @@ -69,57 +67,37 @@ In addition to the physical schemes themselves, this scientific documentation al - \ref radcons The input information for the physics include the values of the gridbox mean prognostic variables (wind components, temperature, -specific humidity, cloud fraction, vater contents for cloud liquid, cloud ice, rain, snow, graupel, and ozone concentration), the provisional +specific humidity, cloud fraction, water contents for cloud liquid, cloud ice, rain, snow, graupel, and ozone concentration), the provisional dynamical tendencies for the same variables and various surface fields, both fixed and variable. -The time integration of the GFS physics suite is based on the following: -- The tendencies from the different physical processes are computed by the parameterizations or derived in separate interstitial routines; +The time integration of the physics suites is based on the following: +- The tendencies from the different physical processes are computed by the parameterizations or derived in separate interstitial routines - The first part of the suite, comprised of the parameterizations for radiation, surface layer, surface (land, ocean, and sea ice), boundary layer, -orographic gravity wave drag, and Rayleigh damping, is computed using a hybrid of parallel and sequential splitting (Donahue and Caldwell(2018) -\cite donahue_and_caldwell_2018), a method in which the various parameterizations use the same model state as input but feel the effect of the preceding +orographic gravity wave drag, and Rayleigh damping, is computed using a hybrid of parallel and sequential splitting described in Donahue and Caldwell(2018) +\cite donahue_and_caldwell_2018, a method in which the various parameterizations use the same model state as input but are impacted by the preceding parameterizations. The tendencies from the various parameterizations are then added together and used to update the model state. -- The second part of the physics suite, comprised of the parameterizations of ozone, stratospheric \f$H_2O\f$, deep convection, convective gravity wave drag, +- The surface parameterizations (land, ocean and sea ice) are invoked twice in a loop, with the first time to create a guess, and the second time to +produce the tendencies. +- The second part of the physics suite, comprised of the parameterizations of ozone, stratospheric water vapor, deep convection, convective gravity wave drag, shallow convection, and microphysics, is computed using sequential splitting in the order listed above, in which the model state is updated between calls to the parameterization. +- If the in-core saturation adjustment is used (\p do_sat_adj=.true.), it is invoked at shorter timesteps along with the dynamical solver. \section allsuite_overview Physics Suites -With funding from the Next Generation Global Prediction System (NGGPS) initiative and broad support from the community NCEP/EMC recently -replaced the dynamic core in its flagship operational model, the GFS. Version 15 of the GFS (GFSv15), schedule for implementation in -middle 2019, will include the Finite-volume Cubed-Sphere (FV3) non-hydrostatic dynamic core in place of the long-running spectral Gaussian -hydrostatic core. - -The next major upgrade of the GFS is expected to be in the area of model physics.Physics upgrades are particular challenging.But community -support, enhanced collaborations, and the CCPP framework are now making it feasible to accelerate advancements in operational model physics -through wholesale replacement of individual parameterizations or even entire parameterizations suites. - -Current plans call for major changes to the GFSv15 parameterization suite in anticipation of the GFSv16 implementaion, schedule for FY2021. -Several parameterizations have been identified as likely new components of the \b GFSv16 suite, including: -- The \b RRTMGP radiation parameterization, developed by Robert Pincus and colleagues, is scheduled to replace the current \ref GFS_RRTMG -- The \b Noah-MP land-surface parameterization is expected to replace the current \ref GFS_NOAH -- A unified gravity-wave-drag (\b UGWD) parameterization, developed by Valery Yudin and collaborators, will replace the separate -\ref GFS_GWDPS and \ref GFS_GWDC currently being used. -- Fresh-water lake (\b FLAKE) and multi-layer snow parameterizations will be introduced to enhance the representation of earth-atmosphere -interactions. - -In addition, new parameterizations for deep and shallow moist convection (CP), cloud microphysics (MP), and planetary boundary layer (PBLP)/ -turbulence are being considered. Unlike the parameterizations mentioned above, there are multiple viable options for parameterizing these -processes in GFSv16, including the schemes currently used in GFSv15. The "suite" approach is being taken for this subset of all model -parameterizations because the individual parameterizations within each candidate CP-MP-PBLP suite are highly interdependent. Thus, optimal -performance typically has been achieved within the candidate suites through collective tuning of individual parameterizations. Developers -have been invited to contribute their parameterizations as members of pre-tuned suites in hopes of optimizing performance in the GFS. This -approach is one way of "leveling the playing field" so that parameterizations developed outside the GFS framework are not unduly handicapped -by sub-optimal interactions with other GFS parameterizations. - - -Two suites of CP-MP-PBLP parameterizations have been identified as possible replacements for the current GFSv15 suite. \b GSD suite is -derived from the operational Rapid Refresh (RAP) and High-Resolution Rapid Refresh (HRRR) modeling system \cite Benjamin_2016 and was developed largely at NOAA/OAR/ESRL/GSD for mesoscale applications, while the second candidate, i.e., the \b CPT \b (Climate Process Team) suite, has components that were -developed at multiple ressearch centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Its individual -parameterizations have been applied primarily to medium-range and longer prediction scales. For the GFSv15 suite, a very similar suite, but -with TKE-EDMF in repace of K-EDMF have been developed at EMC (Han et al. 2019 \cite Han_2019). - -Table 1. physics-suite options included in this documentation. + +The CCPP v3 includes the suite used in the GFS v15 implemented operationally in June 2019 (suite GFS_v15). Additionally, it includes three +developmental suites which are undergoing testing for possible future implementation in the UFS. Suite GFS_v15 plus is identical to suite +GFS_v15 except for a replacement in the PBL parameterization (Han et al. 2019 \cite Han_2019 ). Suite MGCSAW differs from GFS_v15 as it +contains different convection and microphysics schemes made available through a NOAA Climate Process Team (CPT) with components developed +at multiple research centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Suite GSD_v0 differs from v15 as it +uses the convection, microphysics, and boundary layer schemes employed in the Rapid Refresh (RAP) and High-Resolution Rapid Refresh (HRRR \cite Benjamin_2016 ) +operational models and was assembled by NOAA/GSD. An assessment of an earlier version of these suites can be found in + the UFS portal +and in the GMTB website . + +Table 1. Physics suite options included in this documentation. \tableofcontents -| Phys suites | FV3_GFS_v15 | FV3_GFS_v15plus | FV3_CPT_v0 | FV3_GSD_v0 | +| Phys suites | GFS_v15 | GFS_v15plus | MGCSAW | GSD_v0 | |------------------|----------------------|----------------------|---------------------|----------------------| | Deep Cu | \ref GFS_SAMFdeep | \ref GFS_SAMFdeep | \ref CSAW_scheme | \ref GSD_CU_GF | | Shallow Cu | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GSD_MYNNEDMF and \ref cu_gf_sh_group | diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index e88051aaa..0444044cf 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -1,10 +1,22 @@ /** -\page GFSsuite_nml Namelist Option Description +\page GFSsuite_nml Namelist Options Description -\section gfs_physics_nml GFS Physics Parameters -The namelist variable description is provided in host-model side: GFS_typedefs.F90 +At runtime, the SCM and the UFS Atmosphere access runtime configurations from file \c input.nml. This file contains +various namelists that control aspects of the I/O, dynamics, physics etc. Most physics-related options are grouped into +two namelists:&gfs_physics_nml and &gfdl_cloud_microphysics_nml, with additional specifications for stochastic physics in +namelists &stochy_nam and &nam_sfcperts. + +Namelist &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in +module_gfdl_cloud_microphys.F90. + +Namelist &gfs_physics_nml pertains to all of the suites used, but some of the variables are only relevant for specific +parameterizations. Its variables are defined in file GFS_typedefs.F90 in the host model. + +Namelist &stochy_nam specifies options for the use of SPPT, SKEB and SHUM, while namelist &nam_sfcperts specifies whether +and how stochastic perturbations are used in the loah Land surface model. +
NML Description
option DDT in Host Model Description Default Value
\b &gfs_physics_nml
fhzero gfs_control_type hour between clearing of diagnostic buckets 0.0 @@ -156,6 +168,8 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
redrag gfs_control_type logical flag for applying reduced drag coefficient for high wind over sea in GFS surface layer scheme .false.
dspheat gfs_control_type logical flag for using TKE dissipative heating to temperature tendency in hybrid EDMF and TKE-EDMF schemes .false.
hybedmf gfs_control_type logical flag for calling hybrid EDMF PBL scheme .false. +
satmedmf gfs_control_type logical flag for calling TKE EDMF PBL scheme .false. +
do_mynnedmf gfs_control_type flag to activate MYNN-EDMF scheme .false.
random_clds gfs_control_type logical flag for whether clouds are random .false.
trans_trac gfs_control_type logical flag for convective transport of tracers .false.
lheatstrg gfs_control_type logical flag for canopy heat storage parameterization .false. @@ -181,7 +195,7 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F 1
lgfdlmprad gfs_control_type flag for GFDL mp scheme and radiation consistency .false. -
cdmbgwd(2) gfs_control_type multiplication factors for mountain blocking and orographic gravity wave drag /2.0d0,0.25d0/ +
cdmbgwd(2) gfs_control_type multiplication factors for mountain blocking and orographic gravity wave drag 2.0,0.25
prslrd0 gfs_control_type pressure level above which to apply Rayleigh damping 0.0d0
lsm gfs_control_type flag for land surface model to use \n
    @@ -216,14 +230,12 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
/0,0,1,0,5/
nst_anl gfs_control_type flag for NSSTM analysis in gcycle/sfcsub .false. -
satmedmf gfs_control_type logical flag for calling TKE EDMF PBL scheme .false.
effr_in gfs_control_type logical flag for using input cloud effective radii calculation .false.
aero_in gfs_control_type logical flag for using aerosols in Morrison-Gettelman microphysics .false.
iau_delthrs gfs_control_type incremental analysis update (IAU) time interval in hours 6
iaufhrs gfs_control_type forecast hours associated with increment files -1 -
\b CPT_v0 \b Suite \b Specific \b Parameters -
crtrh(3) gfs_control_type critical relative humidity at the surface, PBL top and at the top of the atmosphere /0.90d0,0.90d0,0.90d0/ -
ras gfs_control_type logical flag for RAS convection scheme .false. +
\b Parameters \b Specific \b to \b MGCSAW \b Suite +
crtrh(3) gfs_control_type critical relative humidity at the surface, PBL top and at the top of the atmosphere 0.90,0.90,0.90
cscnv gfs_control_type logical flag for Chikira-Sugiyama deep convection .false.
do_aw gfs_control_type flag for Arakawa-Wu scale-awere adjustment .false.
do_awdd gfs_control_type flag to enable treating convective tendencies following Arakwaw-Wu for downdrafts (2013) .false. @@ -240,19 +252,20 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
xkzm_h gfs_control_type background vertical diffusion for heat and q 1.0d0
xkzm_m gfs_control_type background vertical diffusion for momentum 1.0d0
xkzm_s gfs_control_type sigma threshold for background mom. diffusion 1.0d0 +
xkzminv gfs_control_type maximum background value of heat diffusivity in the inversion layer 0.3
microp_uniform gfs_control_type logical flag for uniform subcolumns for MG microphysics .true.
mg_do_ice_gmao gfs_control_type logical flag for turning on gmao ice autoconversion in MG microphysics .false.
mg_do_liq_liu gfs_control_type logical flag for turning on Liu liquid treatment in MG microphysics .true.
mg_dcs gfs_control_type autoconversion size threshold for cloud ice to snow in MG microphysics 200.0
mg_alf gfs_control_type tuning factor for alphas (alpha = 1 - critical relative humidity) 1.0 -
mg_ts_auto_ice(2) gfs_control_type autoconversion time scale for ice in MG microphysics /180.0,180.0/ +
mg_ts_auto_ice(2) gfs_control_type autoconversion time scale for ice in MG microphysics 180.0,180.0
mg_qcvar gfs_control_type cloud water relative variance in MG microphysics 1.0
mg_rhmini gfs_control_type relative humidity threshold parameter for nucleating ice 1.01
mg_ncnst gfs_control_type constant droplet num concentration \f$m^{-3}\f$ 100.e6
mg_ninst gfs_control_type constant ice num concentration \f$m^{-3}\f$ 0.15e6
mg_ngnst gfs_control_type constant graupel/hail num concertration \f$m^{-3}\f$ 0.10e6
mg_berg_eff_factor gfs_control_type berg efficiency factor 2.0 -
mg_qcmin(2) gfs_control_type min liquid and ice mixing ratio in MG macro clouds /1.0d-9, 1.0d-9/ +
mg_qcmin(2) gfs_control_type min liquid and ice mixing ratio in MG macro clouds 1.0d-9, 1.0d-9
mg_precip_frac_method gfs_control_type type of precipitation fraction method 'max_overlap'
fprcp gfs_control_type number of frozen precipitation species in MG microphysics \n
    @@ -262,15 +275,14 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
0
pdfflag gfs_control_type pdf flag for MG macro physics 4 -
cs_parm(10) gfs_control_type tunable parameters for Chikira-Sugiyama convection /8.0,4.0,1.0e3,3.5e3,20.0,1.0,-999.,1.,0.6,0./ +
cs_parm(10) gfs_control_type tunable parameters for Chikira-Sugiyama convection 8.0,4.0,1.0e3,3.5e3,20.0,1.0,-999.,1.,0.6,0.
iccn gfs_control_type flag for using IN and CCN forcing in MG2/3 microphysics .false.
rhcmax gfs_control_type maximum critical relative humidity 0.9999999 -
\b GSD_v0 \b Suite \b Specific \b Parameters +
\b Parameters \b Specific \b to \b GSD_v0 \b Suite
make_number_concentrations gfs_control_type flag to calculate initial number concentrations from mass concentrations if not in ICs/BCs .false.
ltaerosol gfs_control_type logical flag for using aerosol climotology in Thompson MP scheme .false.
lradar gfs_control_type logical flag for computing radar reflectivity in Thompson MP scheme .false.
ttendlim gfs_control_type temperature tendency limiter per time step in K/s, set to < 0 to deactivate -999.0 -
do_mynnedmf gfs_control_type flag to activate MYNN-EDMF scheme .false.
do_mynnsfclay gfs_control_type flag to activate MYNN-SFCLAY scheme .false.
grav_settling gfs_control_type flag to activate gravitational settling of cloud droplets as described in Nakanishi (2000) \cite nakanishi_2000 0
bl_mynn_mixlength gfs_control_type flag for different version of mixing length formulation \n @@ -337,7 +349,7 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
do_shum gfs_control_type flag for stochastic SHUM option .false.
do_skeb gfs_control_type flag for stochastic SKEB option .false.
do_sfcperts gfs_control_type flag for stochastic surface perturbations option .false. -
\b sfcperts +
\b &nam_sfcperts
nsfcpert gfs_control_type number of weights for stochastic surface perturbation 0
pertz0 gfs_control_type magnitude of perturbation of momentum roughness length -999.
pertzt gfs_control_type magnitude of perturbation of heat to momentum roughness length ratio -999. @@ -349,7 +361,7 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
sfc_tau compns_stochy_mod time scales -999.
sfc_lscale compns_stochy_mod length scales -999.
sppt_land compns_stochy_mod .false. -
\b stochy +
\b &stochy_nam
use_zmtnblck compns_stochy_mod flag for mountain blocking. .T. = do not apply perturbations below the dividing streamline that is diagnosed by the gravity wave drag, mountain blocking scheme .false.
ntrunc compns_stochy_mod spectral resolution (e.g. T126) of random patterns -999
lon_s, lat_s compns_stochy_mod number of longitude and latitude point for the Gaussian grid -999 @@ -377,7 +389,7 @@ The namelist variable description is provided in host-model side: GFS_typedefs.F
skeb_vdof compns_stochy_mod the number of degrees of freedom in the vertical for the SKEB random pattern 5
skeb_sigtop1, skeb_sigtop2 compns_stochy_mod sigma levels to taper perturbations to zeros 0.1, 0.025
skebint compns_stochy_mod 0 -
\b GFDL \b Cloud \b Microphysics \b Parameters +
\b &gfdl_cloud_microphysics_nml
sedi_transport gfdl_cloud_microphys_mod logical flag for turning on horizontal momentum transport during sedimentation .true.
do_sedi_heat gfdl_cloud_microphys_mod logical flag for turning on horizontal heat transport during sedimentation .true.
rad_snow gfdl_cloud_microphys_mod logical flag for considering snow in cloud fraction calculation .true. diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 0157ac763..fc2d4733b 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -44,8 +44,6 @@ !! Part II: Global model solutions and Aerosol-Cloud Interactions. !! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. !! -!! for questions contact Hugh Morrison, Andrew Gettelman -!! e-mail: morrison@ucar.edu, andrew@ucar.edu !! !! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice !! microphysics in cooperation with the MG liquid microphysics. This is diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index f958ab5e8..1113377ba 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -408,7 +408,7 @@ MODULE module_mp_thompson !>\ingroup aathompson !! This subroutine calculates simplified cloud species equations and create !! lookup tables in Thomspson scheme. -!>\section gen_thompson_init GSD thompson_init General Algorithm +!>\section gen_thompson_init thompson_init General Algorithm !> @{ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & ids, ide, jds, jde, kds, kde, & @@ -994,7 +994,7 @@ END SUBROUTINE thompson_init !>\ingroup aathompson !!This is a wrapper routine designed to transfer values from 3D to 1D. -!!\section gen_mpgtdriver GSD Thompson mp_gt_driver General Algorithm +!!\section gen_mpgtdriver Thompson mp_gt_driver General Algorithm !> @{ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa, nifa, nwfa2d, nifa2d, & @@ -1477,7 +1477,7 @@ END SUBROUTINE thompson_finalize !! Previously this code was based on Reisner et al (1998), but few of !! those pieces remain. A complete description is now found in !! Thompson et al. (2004, 2008)\cite Thompson_2004 \cite Thompson_2008. -!>\section gen_mp_thompson GSD mp_thompson General Algorithm +!>\section gen_mp_thompson mp_thompson General Algorithm !> @{ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index e87847f95..f54cee0e5 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -194,7 +194,7 @@ end subroutine mp_thompson_init !! #endif !>\ingroup aathompson -!>\section gen_thompson_hrrr GSD Thompson MP General Algorithm +!>\section gen_thompson_hrrr Thompson MP General Algorithm !>@{ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & spechum, qc, qr, qi, qs, qg, ni, nr, & diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 2e2d472ac..4bf4e2251 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -83,15 +83,14 @@ end subroutine satmedmfvdif_finalize !! !!\section gen_satmedmfvdif GFS satmedmfvdif General Algorithm !! satmedmfvdif_run() computes subgrid vertical turbulence mixing -!! using scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization -!! (Han and Bretherton (2019)). -!! -# For the convective boundary layer, the scheme adopts -!! EDMF parameterization (Siebesma et al., 2007) to take -!! into account nonlocal transport by large eddies (mfpblt.f). -!! -# A new mass-flux parameterization for stratocumulus-top-induced turbulence -!! mixing has been introduced (previously, it was eddy diffusion form) -!! [mfscu.f]. -!! -# For local turbulence mixing, a TKE closure model is used. +!! using the scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization of +!! Han and Bretherton (2019) \cite Han_2019 . +!! -# The local turbulent mixing is represented by an eddy-diffusivity scheme which +!! is a function of a prognostic TKE. +!! -# For the convective boundary layer, nonlocal transport by large eddies +!! (mfpblt.f), is represented using a mass flux approach (Siebesma et al.(2007) \cite Siebesma_2007 ). +!! -# A mass-flux approach is also used to represent the stratocumulus-top-induced turbulence +!! (mfscu.f). !! \section detail_satmedmfvidf GFS satmedmfvdif Detailed Algorithm !> @{ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & @@ -520,7 +519,7 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. enddo ! -!> - Compute critical bulk richardson number (\f$Rb_{cr}\f$) (crb) +!> - Compute critical bulk Richardson number (\f$Rb_{cr}\f$) (crb) !! - For the unstable PBL, crb is a constant (0.25) !! - For the stable boundary layer (SBL), \f$Rb_{cr}\f$ varies !! with the surface Rossby number, \f$R_{0}\f$, as given by @@ -573,7 +572,7 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & enddo enddo ! -! Find pbl height based on bulk richardson number (mrf pbl scheme) +! Find pbl height based on bulk Richardson number (mrf pbl scheme) ! and also for diagnostic purpose ! ! @@ -584,7 +583,7 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & !> - Given the thermal's properties and the critical Richardson number, !! a loop is executed to find the first level above the surface (kpblx) where !! the modified Richardson number is greater than the critical Richardson -!! number, using equation 10a from Toen and Mahrt (1996) \cite troen_and_mahrt_1986 +!! number, using equation 10a from Troen and Mahrt (1996) \cite troen_and_mahrt_1986 !! (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): do k = 1, kmpbl do i = 1, im From 2857802aed75b1bac8202ce47fe6b28d481aa5c6 Mon Sep 17 00:00:00 2001 From: Laurie Carson Date: Thu, 6 Jun 2019 12:34:57 -0600 Subject: [PATCH 03/19] v3.0 release: Prune physics (#260) * remove special linking of interal NCEPlibs for SCM * Prune unnecessary files from physics for SCM v3.0 release --- CMakeLists.txt | 25 +- physics/GFS_phys_time_vary.fv3.F90 | 486 -- physics/GFS_rad_time_vary.fv3.F90 | 114 - physics/GFS_stochastics.F90 | 249 - physics/GFS_suite_init_finalize_test.F90 | 68 - physics/GFS_time_vary_pre.fv3.F90 | 141 - physics/cu_ntiedtke.F90 | 3840 ---------- physics/cu_ntiedtke_post.F90 | 53 - physics/cu_ntiedtke_pre.F90 | 84 - physics/gcm_shoc.F90 | 2040 ----- physics/gcycle.F90 | 245 - physics/gscond.f | 526 -- physics/module_MYNNSFC_wrapper.F90 | 362 - physics/module_sf_mynn.F90 | 2446 ------ physics/moninshoc.f | 607 -- physics/ozphys.f | 202 - physics/precpd.f | 735 -- physics/sfcsub.F | 8745 ---------------------- physics/shinhongvdif.F90 | 2106 ------ physics/ysuvdif.F90 | 1271 ---- 20 files changed, 4 insertions(+), 24341 deletions(-) delete mode 100644 physics/GFS_phys_time_vary.fv3.F90 delete mode 100644 physics/GFS_rad_time_vary.fv3.F90 delete mode 100644 physics/GFS_stochastics.F90 delete mode 100644 physics/GFS_suite_init_finalize_test.F90 delete mode 100644 physics/GFS_time_vary_pre.fv3.F90 delete mode 100644 physics/cu_ntiedtke.F90 delete mode 100644 physics/cu_ntiedtke_post.F90 delete mode 100644 physics/cu_ntiedtke_pre.F90 delete mode 100644 physics/gcm_shoc.F90 delete mode 100644 physics/gcycle.F90 delete mode 100644 physics/gscond.f delete mode 100644 physics/module_MYNNSFC_wrapper.F90 delete mode 100644 physics/module_sf_mynn.F90 delete mode 100644 physics/moninshoc.f delete mode 100644 physics/ozphys.f delete mode 100644 physics/precpd.f delete mode 100644 physics/sfcsub.F delete mode 100644 physics/shinhongvdif.F90 delete mode 100644 physics/ysuvdif.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index ff6a08455..af33fb1ee 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -263,19 +263,6 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") endif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") if (PROJECT STREQUAL "CCPP-SCM") - SET(W3LIB_SRC ${CMAKE_CURRENT_SOURCE_DIR}/../../external/w3nco/v2.0.6/src) - SET(BACIOLIB_SRC ${CMAKE_CURRENT_SOURCE_DIR}/../../external/bacio/v2.0.1/src) - SET(SPLIB_SRC ${CMAKE_CURRENT_SOURCE_DIR}/../../external/sp/v2.0.2/src) - - #add "sibling" directories (must specify the build directory too) - ADD_SUBDIRECTORY(${W3LIB_SRC} ${CMAKE_BINARY_DIR}/w3nco) - ADD_SUBDIRECTORY(${BACIOLIB_SRC} ${CMAKE_BINARY_DIR}/bacio) - ADD_SUBDIRECTORY(${SPLIB_SRC} ${CMAKE_BINARY_DIR}/sp) - - INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/w3nco) - INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/sp) - INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/bacio) - INCLUDE_DIRECTORIES(${CMAKE_BINARY_DIR}/ccpp/framework/src) endif (PROJECT STREQUAL "CCPP-SCM") @@ -293,14 +280,10 @@ else(STATIC) add_library(ccppphys SHARED ${SCHEMES} ${SCHEMES_SFX} ${CAPS}) endif(STATIC) -if (PROJECT STREQUAL "CCPP-FV3") - # Link required NCEPlibs for dynamic builds - if (NOT STATIC) - target_link_libraries(ccppphys LINK_PUBLIC ${LIBS} ${BACIO_LIB4} ${SP_LIBd} ${W3NCO_LIBd}) - endif (NOT STATIC) -elseif (PROJECT STREQUAL "CCPP-SCM") - target_link_libraries(ccppphys LINK_PUBLIC ${LIBS} w3 sp bacio) -endif (PROJECT STREQUAL "CCPP-FV3") +if (NOT STATIC) + target_link_libraries(ccppphys LINK_PUBLIC ${LIBS} ${BACIO_LIB4} ${SP_LIBd} ${W3NCO_LIBd}) +endif (NOT STATIC) + set_target_properties(ccppphys PROPERTIES VERSION ${PROJECT_VERSION} SOVERSION ${PROJECT_VERSION_MAJOR}) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 deleted file mode 100644 index b8823fac6..000000000 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ /dev/null @@ -1,486 +0,0 @@ -!> \file GFS_phys_time_vary.fv3.F90 -!! Contains code related to GFS physics suite setup (physics part of time_vary_step) - -!>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, h2o, i -!! aerosol and IN&CCN updates. - module GFS_phys_time_vary - -#ifdef OPENMP - use omp_lib -#endif - - use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin - use ozinterp, only : read_o3data, setindxoz, ozinterpol - - use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin - use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol - - use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm - use aerinterp, only : read_aerdata, setindxaer, aerinterpol - - use iccn_def, only : ciplin, ccnin, ci_pres - use iccninterp, only : read_cidata, setindxci, ciinterpol - - implicit none - - private - - public GFS_phys_time_vary_init, GFS_phys_time_vary_run, GFS_phys_time_vary_finalize - - logical :: is_initialized = .false. - - contains - -!> \section arg_table_GFS_phys_time_vary_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | Interstitial | GFS_interstitial_type_instance_all_threads | Fortran DDT containing FV3-GFS interstitial data | DDT | 1 | GFS_interstitial_type | | inout | F | -!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, errflg) - - use GFS_typedefs, only: GFS_control_type, GFS_data_type, GFS_interstitial_type - - implicit none - - ! Interface variables - type(GFS_data_type), intent(inout) :: Data(:) - type(GFS_control_type), intent(inout) :: Model - type(GFS_interstitial_type), intent(inout) :: Interstitial(:) - integer, intent(in) :: nthrds - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: nb, nblks, nt - integer :: i, j, ix - logical :: non_uniform_blocks - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (is_initialized) return - - nblks = size(Model%blksz) - - ! Non-uniform blocks require special handling: instead - ! of nthrds elements of the Interstitial array, there are - ! nthrds+1 elements. The extra Interstitial(nthrds+1) is - ! allocated for the smaller block length of the last block, - ! while all other elements are allocated to the maximum - ! block length (which is the same for all blocks except - ! the last block). - if (minval(Model%blksz)==maxval(Model%blksz)) then - non_uniform_blocks = .false. - else - non_uniform_blocks = .true. - end if - - ! Consistency check - number of threads passed in via the argument list - ! has to match the size of the Interstitial data type. - if (.not. non_uniform_blocks .and. nthrds/=size(Interstitial)) then - write(errmsg,'(*(a))') 'Logic error: nthrds does not match size of Interstitial variable' - errflg = 1 - return - else if (non_uniform_blocks .and. nthrds+1/=size(Interstitial)) then - write(errmsg,'(*(a))') 'Logic error: nthrds+1 does not match size of Interstitial variable ' // & - '(including extra last element for shorter blocksizes)' - errflg = 1 - return - end if - -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nt,nb) & -!$OMP shared (Model,Data,Interstitial,errmsg,errflg) & -!$OMP shared (levozp,oz_coeff,oz_pres) & -!$OMP shared (levh2o,h2o_coeff,h2o_pres) & -!$OMP shared (ntrcaer,nblks,nthrds,non_uniform_blocks) - -#ifdef OPENMP - nt = omp_get_thread_num()+1 -#else - nt = 1 -#endif - -!$OMP sections - -!$OMP section - call read_o3data (Model%ntoz, Model%me, Model%master) - - ! Consistency check that the hardcoded values for levozp and - ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) - if (size(Data(1)%Tbd%ozpl, dim=2).ne.levozp) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & - levozp, " /= ", size(Data(1)%Tbd%ozpl, dim=2) - errflg = 1 - end if - if (size(Data(1)%Tbd%ozpl, dim=3).ne.oz_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & - oz_coeff, " /= ", size(Data(1)%Tbd%ozpl, dim=3) - errflg = 1 - end if - -!$OMP section - call read_h2odata (Model%h2o_phys, Model%me, Model%master) - - ! Consistency check that the hardcoded values for levh2o and - ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data - ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) - if (size(Data(1)%Tbd%h2opl, dim=2).ne.levh2o) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "levh2o from read_h2odata does not match value in GFS_typedefs.F90: ", & - levh2o, " /= ", size(Data(1)%Tbd%h2opl, dim=2) - errflg = 1 - end if - if (size(Data(1)%Tbd%h2opl, dim=3).ne.h2o_coeff) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "h2o_coeff from read_h2odata does not match value in GFS_typedefs.F90: ", & - h2o_coeff, " /= ", size(Data(1)%Tbd%h2opl, dim=3) - errflg = 1 - end if - -!$OMP section - if (Model%aero_in) then - ! Consistency check that the value for ntrcaerm set in GFS_typedefs.F90 - ! and used to allocate Tbd%aer_nm matches the value defined in aerclm_def - if (size(Data(1)%Tbd%aer_nm, dim=3).ne.ntrcaerm) then - write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & - "ntrcaerm from aerclm_def does not match value in GFS_typedefs.F90: ", & - ntrcaerm, " /= ", size(Data(1)%Tbd%aer_nm, dim=3) - errflg = 1 - else - ! Update the value of ntrcaer in aerclm_def with the value defined - ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. - ! If Model%aero_in is .true., then ntrcaer == ntrcaerm - ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) - ! Read aerosol climatology - call read_aerdata (Model%me,Model%master,Model%iflip,Model%idate) - endif - else - ! Update the value of ntrcaer in aerclm_def with the value defined - ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. - ! If Model%aero_in is .false., then ntrcaer == 1 - ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) - endif - -!$OMP section - if (Model%iccn) then - call read_cidata ( Model%me, Model%master) - ! No consistency check needed for in/ccn data, all values are - ! hardcoded in module iccn_def.F and GFS_typedefs.F90 - endif - -!$OMP end sections - - ! Update values of oz_pres in Interstitial data type for all threads - if (Model%ntoz > 0) then - Interstitial(nt)%oz_pres = oz_pres -!$OMP single - if (non_uniform_blocks) then - ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres - Interstitial(nthrds+1)%oz_pres = oz_pres - end if -!$OMP end single nowait - end if - - ! Update values of h2o_pres in Interstitial data type for all threads - if (Model%h2o_phys) then - Interstitial(nt)%h2o_pres = h2o_pres -!$OMP single - if (non_uniform_blocks) then - ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres - Interstitial(nthrds+1)%h2o_pres = h2o_pres - end if -!$OMP end single nowait - end if - - - !--- read in and initialize ozone - if (Model%ntoz > 0) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxoz (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_o3, & - Data(nb)%Grid%jindx2_o3, Data(nb)%Grid%ddy_o3) - enddo -!$OMP end do - endif - - !--- read in and initialize stratospheric water - if (Model%h2o_phys) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxh2o (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_h, & - Data(nb)%Grid%jindx2_h, Data(nb)%Grid%ddy_h) - enddo -!$OMP end do - endif - - !--- read in and initialize aerosols - if (Model%aero_in) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxaer (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_aer, & - Data(nb)%Grid%jindx2_aer, Data(nb)%Grid%ddy_aer, Data(nb)%Grid%xlon_d, & - Data(nb)%Grid%iindx1_aer, Data(nb)%Grid%iindx2_aer, Data(nb)%Grid%ddx_aer, & - Model%me, Model%master) - enddo -!$OMP end do - endif - - !--- read in and initialize IN and CCN - if (Model%iccn) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call setindxci (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_ci, & - Data(nb)%Grid%jindx2_ci, Data(nb)%Grid%ddy_ci, Data(nb)%Grid%xlon_d, & - Data(nb)%Grid%iindx1_ci, Data(nb)%Grid%iindx2_ci, Data(nb)%Grid%ddx_ci) - enddo -!$OMP end do - endif - -!$OMP end parallel - - !--- initial calculation of maps local ix -> global i and j, store in Tbd - ix = 0 - nb = 1 - do j = 1,Model%ny - do i = 1,Model%nx - ix = ix + 1 - if (ix .gt. Model%blksz(nb)) then - ix = 1 - nb = nb + 1 - endif - Data(nb)%Tbd%jmap(ix) = j - Data(nb)%Tbd%imap(ix) = i - enddo - enddo - - is_initialized = .true. - - end subroutine GFS_phys_time_vary_init - - -!> \section arg_table_GFS_phys_time_vary_finalize Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_phys_time_vary_finalize(errmsg, errflg) - - implicit none - - ! Interface variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not.is_initialized) return - - ! Deallocate ozone arrays - if (allocated(oz_lat) ) deallocate(oz_lat) - if (allocated(oz_pres) ) deallocate(oz_pres) - if (allocated(oz_time) ) deallocate(oz_time) - if (allocated(ozplin) ) deallocate(ozplin) - - ! Deallocate h2o arrays - if (allocated(h2o_lat) ) deallocate(h2o_lat) - if (allocated(h2o_pres)) deallocate(h2o_pres) - if (allocated(h2o_time)) deallocate(h2o_time) - if (allocated(h2oplin) ) deallocate(h2oplin) - - ! Deallocate aerosol arrays - if (allocated(aerin) ) deallocate(aerin) - if (allocated(aer_pres)) deallocate(aer_pres) - - ! Deallocate IN and CCN arrays - if (allocated(ciplin) ) deallocate(ciplin) - if (allocated(ccnin) ) deallocate(ccnin) - if (allocated(ci_pres) ) deallocate(ci_pres) - - is_initialized = .false. - - end subroutine GFS_phys_time_vary_finalize - - -!> \section arg_table_GFS_phys_time_vary_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) - - use mersenne_twister, only: random_setseed, random_number - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_data_type - - implicit none - - ! Interface variables - type(GFS_data_type), intent(in) :: Data(:) - type(GFS_control_type), intent(inout) :: Model - integer, intent(in) :: nthrds - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys - real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys - real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - - integer :: i, j, k, iseed, iskip, ix, nb, nblks - real(kind=kind_phys) :: wrk(1) - real(kind=kind_phys) :: rannie(Model%cny) - real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Check initialization status - if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_phys_time_vary_run called before GFS_phys_time_vary_init" - errflg = 1 - return - end if - - nblks = size(Model%blksz) - - !--- switch for saving convective clouds - cnvc90.f - !--- aka Ken Campana/Yu-Tai Hou legacy - if ((mod(Model%kdt,Model%nsswr) == 0) .and. (Model%lsswr)) then - !--- initialize,accumulate,convert - Model%clstp = 1100 + min(Model%fhswr/con_hr,Model%fhour,con_99) - elseif (mod(Model%kdt,Model%nsswr) == 0) then - !--- accumulate,convert - Model%clstp = 0100 + min(Model%fhswr/con_hr,Model%fhour,con_99) - elseif (Model%lsswr) then - !--- initialize,accumulate - Model%clstp = 1100 - else - !--- accumulate - Model%clstp = 0100 - endif - -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nb,iskip,ix,i,j,k) & -!$OMP shared (Model,Data,iseed,wrk,rannie,rndval) & -!$OMP shared (nblks) - - !--- random number needed for RAS and old SAS and when cal_pre=.true. - ! Model%imfdeepcnv < 0 when Model%ras = .true. - if ( (Model%imfdeepcnv <= 0 .or. Model%cal_pre) .and. Model%random_clds ) then -!$OMP single - iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0 - call random_setseed(iseed) - call random_number(wrk) - do i = 1,Model%cnx*Model%nrcm - iseed = iseed + nint(wrk(1)*1000.0) * i - call random_setseed(iseed) - call random_number(rannie) - rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny) - enddo -!$OMP end single - - do k = 1,Model%nrcm - iskip = (k-1)*Model%cnx*Model%cny -!$OMP do schedule (dynamic,1) - do nb=1,nblks - do ix=1,Model%blksz(nb) - j = Data(nb)%Tbd%jmap(ix) - i = Data(nb)%Tbd%imap(ix) - Data(nb)%Tbd%rann(ix,k) = rndval(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + iskip) - enddo - enddo -!$OMP end do - enddo - endif ! imfdeepcnv, cal_re, random_clds - - !--- o3 interpolation - if (Model%ntoz > 0) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call ozinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_o3, Data(nb)%Grid%jindx2_o3, & - Data(nb)%Tbd%ozpl, Data(nb)%Grid%ddy_o3) - enddo -!$OMP end do - endif - - !--- h2o interpolation - if (Model%h2o_phys) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call h2ointerpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_h, Data(nb)%Grid%jindx2_h, & - Data(nb)%Tbd%h2opl, Data(nb)%Grid%ddy_h) - enddo -!$OMP end do - endif - - !--- aerosol interpolation - if (Model%aero_in) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call aerinterpol (Model%me, Model%master, Model%blksz(nb), & - Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_aer, Data(nb)%Grid%jindx2_aer, & - Data(nb)%Grid%ddy_aer,Data(nb)%Grid%iindx1_aer, & - Data(nb)%Grid%iindx2_aer,Data(nb)%Grid%ddx_aer, & - Model%levs,Data(nb)%Statein%prsl, & - Data(nb)%Tbd%aer_nm) - enddo -!$OMP end do - endif - - !--- ICCN interpolation - if (Model%iccn) then -!$OMP do schedule (dynamic,1) - do nb = 1, nblks - call ciinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & - Data(nb)%Grid%jindx1_ci, Data(nb)%Grid%jindx2_ci, & - Data(nb)%Grid%ddy_ci,Data(nb)%Grid%iindx1_ci, & - Data(nb)%Grid%iindx2_ci,Data(nb)%Grid%ddx_ci, & - Model%levs,Data(nb)%Statein%prsl, & - Data(nb)%Tbd%in_nm, Data(nb)%Tbd%ccn_nm) - enddo -!$OMP end do - endif - -!$OMP end parallel - - !--- repopulate specific time-varying sfc properties for AMIP/forecast runs - if (Model%nscyc > 0) then - if (mod(Model%kdt,Model%nscyc) == 1) THEN - call gcycle (nblks, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) - endif - endif - - !--- determine if diagnostics buckets need to be cleared - if (mod(Model%kdt,Model%nszero) == 1) then - do nb = 1,nblks - call Data(nb)%Intdiag%rad_zero (Model) - call Data(nb)%Intdiag%phys_zero (Model) - !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED - enddo - endif - - end subroutine GFS_phys_time_vary_run - - end module GFS_phys_time_vary diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 deleted file mode 100644 index ac96e78d0..000000000 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ /dev/null @@ -1,114 +0,0 @@ -!>\file GFS_rad_time_vary.F90 -!! Contains code related to GFS physics suite setup (radiation part of time_vary_step) - module GFS_rad_time_vary - - implicit none - - private - - public GFS_rad_time_vary_init, GFS_rad_time_vary_run, GFS_rad_time_vary_finalize - - contains - -!>\defgroup GFS_rad_time_vary GFS RRTMG Update -!!\ingroup RRTMG -!! @{ -!! \section arg_table_GFS_rad_time_vary_init Argument Table -!! - subroutine GFS_rad_time_vary_init - end subroutine GFS_rad_time_vary_init - -!> \section arg_table_GFS_rad_time_vary_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-------------------|--------------------------------------------------------|-------------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | -!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_rad_time_vary_run (Model, Data, nthrds, errmsg, errflg) - - use physparam, only: ipsd0, ipsdlim, iaerflg - use mersenne_twister, only: random_setseed, random_index, random_stat - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, & - GFS_data_type - use radcons, only: qmin, con_100 - - implicit none - - type(GFS_control_type), intent(inout) :: Model - type(GFS_data_type), intent(inout) :: Data(:) - integer, intent(in) :: nthrds - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - !--- local variables - type (random_stat) :: stat - integer :: ix, nb, j, i, nblks, ipseed - integer :: numrdm(Model%cnx*Model%cny*2) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (Model%lsswr .or. Model%lslwr) then - - nblks = size(Model%blksz) - - !--- call to GFS_radupdate_run is now in GFS_rrtmg_setup_run - -!$OMP parallel num_threads(nthrds) default(none) & -!$OMP private (nb,ix,i,j) & -!$OMP shared (Model,Data,ipsdlim,ipsd0,ipseed) & -!$OMP shared (numrdm,stat,nblks) - - !--- set up random seed index in a reproducible way for entire cubed-sphere face (lat-lon grid) - if ((Model%isubc_lw==2) .or. (Model%isubc_sw==2)) then -!$OMP single - ipseed = mod(nint(con_100*sqrt(Model%sec)), ipsdlim) + 1 + ipsd0 - call random_setseed (ipseed, stat) - call random_index (ipsdlim, numrdm, stat) -!$OMP end single - -!$OMP do schedule (dynamic,1) - do nb=1,nblks - do ix=1,Model%blksz(nb) - j = Data(nb)%Tbd%jmap(ix) - i = Data(nb)%Tbd%imap(ix) - !--- for testing purposes, replace numrdm with '100' - Data(nb)%Tbd%icsdsw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx) - Data(nb)%Tbd%icsdlw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + Model%cnx*Model%cny) - enddo - enddo -!$OMP end do - endif ! isubc_lw and isubc_sw - - if (Model%imp_physics == 99) then - if (Model%kdt == 1) then -!$OMP do schedule (dynamic,1) - do nb = 1,nblks - Data(nb)%Tbd%phy_f3d(:,:,1) = Data(nb)%Statein%tgrs - Data(nb)%Tbd%phy_f3d(:,:,2) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) - Data(nb)%Tbd%phy_f3d(:,:,3) = Data(nb)%Statein%tgrs - Data(nb)%Tbd%phy_f3d(:,:,4) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) - Data(nb)%Tbd%phy_f2d(:,1) = Data(nb)%Statein%prsi(:,1) - Data(nb)%Tbd%phy_f2d(:,2) = Data(nb)%Statein%prsi(:,1) - enddo -!$OMP end do - endif - endif - -!$OMP end parallel - - endif - - end subroutine GFS_rad_time_vary_run - -!> \section arg_table_GFS_rad_time_vary_finalize Argument Table -!! - subroutine GFS_rad_time_vary_finalize() - end subroutine GFS_rad_time_vary_finalize -!! @} - end module GFS_rad_time_vary diff --git a/physics/GFS_stochastics.F90 b/physics/GFS_stochastics.F90 deleted file mode 100644 index 7fa2e256b..000000000 --- a/physics/GFS_stochastics.F90 +++ /dev/null @@ -1,249 +0,0 @@ -!> \file GFS_stochastics.f90 -!! This file contains code previously in GFS_stochastics_driver. - - module GFS_stochastics - - contains - - subroutine GFS_stochastics_init () - end subroutine GFS_stochastics_init - - subroutine GFS_stochastics_finalize() - end subroutine GFS_stochastics_finalize - - -!>\defgroup gfs_stoch GFS Stochastics Physics Module -!! This module -!> @{ -!> \section arg_table_GFS_stochastics_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|---------------------------------------------------------------------------|--------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | km | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | -!! | do_sppt | flag_for_stochastic_surface_physics_perturbations | flag for stochastic surface physics perturbations | flag | 0 | logical | | in | F | -!! | use_zmtnblck | flag_for_mountain_blocking | flag for mountain blocking | flag | 0 | logical | | in | F | -!! | do_shum | flag_for_stochastic_shum_option | flag for stochastic shum option | flag | 0 | logical | | in | F | -!! | do_skeb | flag_for_stochastic_skeb_option | flag for stochastic skeb option | flag | 0 | logical | | in | F | -!! | zmtnblck | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | in | F | -!! | sppt_wts | weights_for_stochastic_sppt_perturbation | weights for stochastic sppt perturbation | none | 2 | real | kind_phys | inout | F | -!! | skebu_wts | weights_for_stochastic_skeb_perturbation_of_x_wind | weights for stochastic skeb perturbation of x wind | none | 2 | real | kind_phys | in | F | -!! | skebv_wts | weights_for_stochastic_skeb_perturbation_of_y_wind | weights for stochastic skeb perturbation of y wind | none | 2 | real | kind_phys | in | F | -!! | shum_wts | weights_for_stochastic_shum_perturbation | weights for stochastic shum perturbation | none | 2 | real | kind_phys | in | F | -!! | sppt_wts_inv | weights_for_stochastic_sppt_perturbation_flipped | weights for stochastic sppt perturbation, flipped | none | 2 | real | kind_phys | inout | F | -!! | skebu_wts_inv | weights_for_stochastic_skeb_perturbation_of_x_wind_flipped | weights for stochastic skeb perturbation of x wind, flipped | none | 2 | real | kind_phys | inout | F | -!! | skebv_wts_inv | weights_for_stochastic_skeb_perturbation_of_y_wind_flipped | weights for stochastic skeb perturbation of y wind, flipped | none | 2 | real | kind_phys | inout | F | -!! | shum_wts_inv | weights_for_stochastic_shum_perturbation_flipped | weights for stochastic shum perturbation, flipped | none | 2 | real | kind_phys | inout | F | -!! | diss_est | dissipation_estimate_of_air_temperature_at_model_layers | dissipation estimate model layer mean temperature | K | 2 | real | kind_phys | in | F | -!! | ugrs | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vgrs | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tgrs | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | -!! | qgrs | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!! | gu0 | x_wind_updated_by_physics | zonal wind updated by physics | m s-1 | 2 | real | kind_phys | inout | F | -!! | gv0 | y_wind_updated_by_physics | meridional wind updated by physics | m s-1 | 2 | real | kind_phys | inout | F | -!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | -!! | gq0 | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | dtdtr | tendency_of_air_temperature_due_to_radiative_heating_on_physics_time_step | temp. change due to radiative heating per time step | K | 2 | real | kind_phys | in | F | -!! | rain | lwe_thickness_of_precipitation_amount_on_dynamics_timestep | total rain at this time step | m | 1 | real | kind_phys | in | F | -!! | rainc | lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep | convective rain at this time step | m | 1 | real | kind_phys | in | F | -!! | tprcp | nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep | total precipitation amount in each time step | m | 1 | real | kind_phys | inout | F | -!! | totprcp | accumulated_lwe_thickness_of_precipitation_amount | accumulated total precipitation | m | 1 | real | kind_phys | inout | F | -!! | cnvprcp | cumulative_lwe_thickness_of_convective_precipitation_amount | cumulative convective precipitation | m | 1 | real | kind_phys | inout | F | -!! | totprcpb | accumulated_lwe_thickness_of_precipitation_amount_in_bucket | accumulated total precipitation in bucket | m | 1 | real | kind_phys | inout | F | -!! | cnvprcpb | cumulative_lwe_thickness_of_convective_precipitation_amount_in_bucket | cumulative convective precipitation in bucket | m | 1 | real | kind_phys | inout | F | -!! | cplflx | flag_for_flux_coupling | flag controlling cplflx collection (default off) | flag | 0 | logical | | in | F | -!! | rain_cpl | lwe_thickness_of_precipitation_amount_for_coupling | total rain precipitation | m | 1 | real | kind_phys | inout | F | -!! | snow_cpl | lwe_thickness_of_snow_amount_for_coupling | total snow precipitation | m | 1 | real | kind_phys | inout | F | -!! | drain_cpl | tendency_of_lwe_thickness_of_precipitation_amount_for_coupling | change in rain_cpl (coupling_type) | m | 1 | real | kind_phys | in | F | -!! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!>\section gfs_stochy_general GFS_stochastics_run General Algorithm -!! This is the GFS stochastic physics driver. -!! Routines are called prior to radiation and physics steps to handle: -!! -# sets up various time/date variables -!! -# sets up various triggers -!! -# defines random seed indices for radiation (in a reproducible way) -!! -# interpolates coefficients for prognostic ozone calculation -!! -# performs surface data cycling via the GFS gcycle routine - subroutine GFS_stochastics_run (im, km, do_sppt, use_zmtnblck, do_shum, do_skeb, & - zmtnblck, sppt_wts, skebu_wts, skebv_wts, shum_wts,& - sppt_wts_inv, skebu_wts_inv, skebv_wts_inv, & - shum_wts_inv, diss_est, & - ugrs, vgrs, tgrs, qgrs, gu0, gv0, gt0, gq0, dtdtr, & - rain, rainc, tprcp, totprcp, cnvprcp, & - totprcpb, cnvprcpb, cplflx, & - rain_cpl, snow_cpl, drain_cpl, dsnow_cpl, & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im - integer, intent(in) :: km - logical, intent(in) :: do_sppt - logical, intent(in) :: use_zmtnblck - logical, intent(in) :: do_shum - logical, intent(in) :: do_skeb - !logical, intent(in) :: isppt_deep - real(kind_phys), dimension(1:im), intent(in) :: zmtnblck - ! sppt_wts only allocated if do_sppt == .true. - real(kind_phys), dimension(:,:), intent(inout) :: sppt_wts - ! skebu_wts, skebv_wts only allocated if do_skeb == .true. - real(kind_phys), dimension(:,:), intent(in) :: skebu_wts - real(kind_phys), dimension(:,:), intent(in) :: skebv_wts - ! shum_wts only allocated if do_shum == .true. - real(kind_phys), dimension(:,:), intent(in) :: shum_wts - ! inverse/flipped weights are always allocated - real(kind_phys), dimension(1:im,1:km), intent(inout) :: sppt_wts_inv - real(kind_phys), dimension(1:im,1:km), intent(inout) :: skebu_wts_inv - real(kind_phys), dimension(1:im,1:km), intent(inout) :: skebv_wts_inv - real(kind_phys), dimension(1:im,1:km), intent(inout) :: shum_wts_inv - real(kind_phys), dimension(1:im,1:km), intent(in) :: diss_est - real(kind_phys), dimension(1:im,1:km), intent(in) :: ugrs - real(kind_phys), dimension(1:im,1:km), intent(in) :: vgrs - real(kind_phys), dimension(1:im,1:km), intent(in) :: tgrs - real(kind_phys), dimension(1:im,1:km), intent(in) :: qgrs - real(kind_phys), dimension(1:im,1:km), intent(inout) :: gu0 - real(kind_phys), dimension(1:im,1:km), intent(inout) :: gv0 - real(kind_phys), dimension(1:im,1:km), intent(inout) :: gt0 - real(kind_phys), dimension(1:im,1:km), intent(inout) :: gq0 - ! dtdtr only allocated if do_sppt == .true. - real(kind_phys), dimension(:,:), intent(in) :: dtdtr - real(kind_phys), dimension(1:im), intent(in) :: rain - real(kind_phys), dimension(1:im), intent(in) :: rainc - real(kind_phys), dimension(1:im), intent(inout) :: tprcp - real(kind_phys), dimension(1:im), intent(inout) :: totprcp - real(kind_phys), dimension(1:im), intent(inout) :: cnvprcp - real(kind_phys), dimension(1:im), intent(inout) :: totprcpb - real(kind_phys), dimension(1:im), intent(inout) :: cnvprcpb - logical, intent(in) :: cplflx - ! rain_cpl, snow_cpl only allocated if cplflx == .true. or do_sppt == .true. - real(kind_phys), dimension(:), intent(inout) :: rain_cpl - real(kind_phys), dimension(:), intent(inout) :: snow_cpl - ! drain_cpl, dsnow_cpl only allocated if do_sppt == .true. - real(kind_phys), dimension(:), intent(in) :: drain_cpl - real(kind_phys), dimension(:), intent(in) :: dsnow_cpl - ! tconvtend ... vconvtend only allocated if isppt_deep == .true. - !real(kind_phys), dimension(:,:), intent(in) :: tconvtend - !real(kind_phys), dimension(:,:), intent(in) :: qconvtend - !real(kind_phys), dimension(:,:), intent(in) :: uconvtend - !real(kind_phys), dimension(:,:), intent(in) :: vconvtend - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - !--- local variables - integer :: k, i - real(kind=kind_phys) :: upert, vpert, tpert, qpert, qnew, sppt_vwt - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (do_sppt) then - do k=1,km - do i=1,im - sppt_vwt=1.0 - if (zmtnblck(i).EQ.0.0) then - sppt_vwt=1.0 - else - if (k.GT.zmtnblck(i)+2) then - sppt_vwt=1.0 - endif - if (k.LE.zmtnblck(i)) then - sppt_vwt=0.0 - endif - if (k.EQ.zmtnblck(i)+1) then - sppt_vwt=0.333333 - endif - if (k.EQ.zmtnblck(i)+2) then - sppt_vwt=0.666667 - endif - endif - if (use_zmtnblck)then - sppt_wts(i,k)=(sppt_wts(i,k)-1)*sppt_vwt+1.0 - endif - sppt_wts_inv(i,km-k+1)=sppt_wts(i,k) - - !if(isppt_deep)then - - ! upert = (gu0(i,k) - ugrs(i,k) - uconvtend(i,k)) + uconvtend(i,k) * sppt_wts(i,k) - ! vpert = (gv0(i,k) - vgrs(i,k) - vconvtend(i,k)) + vconvtend(i,k) * sppt_wts(i,k) - ! tpert = (gt0(i,k) - tgrs(i,k) - dtdtr(i,k) - tconvtend(i,k)) + tconvtend(i,k) * sppt_wts(i,k) - ! qpert = (gq0(i,k) - qgrs(i,k) - qconvtend(i,k)) + qconvtend(i,k) * sppt_wts(i,k) - - !else - - upert = (gu0(i,k) - ugrs(i,k)) * sppt_wts(i,k) - vpert = (gv0(i,k) - vgrs(i,k)) * sppt_wts(i,k) - tpert = (gt0(i,k) - tgrs(i,k) - dtdtr(i,k)) * sppt_wts(i,k) - qpert = (gq0(i,k) - qgrs(i,k)) * sppt_wts(i,k) - - !endif - - gu0(i,k) = ugrs(i,k)+upert - gv0(i,k) = vgrs(i,k)+vpert - - !negative humidity check - qnew = qgrs(i,k)+qpert - if (qnew >= 1.0e-10) then - gq0(i,k) = qnew - gt0(i,k) = tgrs(i,k) + tpert + dtdtr(i,k) - endif - enddo - enddo - - !if(isppt_deep)then - ! tprcp(:) = tprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) - ! totprcp(:) = totprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) - ! cnvprcp(:) = cnvprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) - !! ! bucket precipitation adjustment due to sppt - ! totprcpb(:) = totprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) - ! cnvprcpb(:) = cnvprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) - - ! if (cplflx) then !Need to make proper adjustments for deep convection only perturbations - ! rain_cpl(:) = rain_cpl(:) + (sppt_wts(:,15) - 1.0)*drain_cpl(:) - ! snow_cpl(:) = snow_cpl(:) + (sppt_wts(:,15) - 1.0)*dsnow_cpl(:) - ! endif - - !else - - ! instantaneous precip rate going into land model at the next time step - tprcp(:) = sppt_wts(:,15)*tprcp(:) - totprcp(:) = totprcp(:) + (sppt_wts(:,15) - 1 )*rain(:) - ! acccumulated total and convective preciptiation - cnvprcp(:) = cnvprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) - ! bucket precipitation adjustment due to sppt - totprcpb(:) = totprcpb(:) + (sppt_wts(:,15) - 1 )*rain(:) - cnvprcpb(:) = cnvprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) - - if (cplflx) then - rain_cpl(:) = rain_cpl(:) + (sppt_wts(:,15) - 1.0)*drain_cpl(:) - snow_cpl(:) = snow_cpl(:) + (sppt_wts(:,15) - 1.0)*dsnow_cpl(:) - endif - - !endif - - endif - - if (do_shum) then - do k=1,km - gq0(:,k) = gq0(:,k)*(1.0 + shum_wts(:,k)) - shum_wts_inv(:,km-k+1) = shum_wts(:,k) - end do - endif - - if (do_skeb) then - do k=1,km - gu0(:,k) = gu0(:,k)+skebu_wts(:,k)*(diss_est(:,k)) - gv0(:,k) = gv0(:,k)+skebv_wts(:,k)*(diss_est(:,k)) - skebu_wts_inv(:,km-k+1) = skebu_wts(:,k) - skebv_wts_inv(:,km-k+1) = skebv_wts(:,k) - enddo - endif - - end subroutine GFS_stochastics_run - - end module GFS_stochastics -!> @} diff --git a/physics/GFS_suite_init_finalize_test.F90 b/physics/GFS_suite_init_finalize_test.F90 deleted file mode 100644 index efd0530e2..000000000 --- a/physics/GFS_suite_init_finalize_test.F90 +++ /dev/null @@ -1,68 +0,0 @@ - module GFS_suite_ini_fini_test - - contains - -!> \section arg_table_GFS_suite_ini_fini_test_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_suite_ini_fini_test_init (errmsg, errflg) - - implicit none - - ! interface variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - write(0,*) "DH DEBUG: IN GFS_suite_ini_fini_test_init" - - end subroutine GFS_suite_ini_fini_test_init - -!> \section arg_table_GFS_suite_ini_fini_test_finalize Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_suite_ini_fini_test_finalize(errmsg, errflg) - - implicit none - - ! interface variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - write(0,*) "DH DEBUG: IN GFS_suite_ini_fini_test_finalize" - - end subroutine GFS_suite_ini_fini_test_finalize - -!> \section arg_table_GFS_suite_ini_fini_test_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_suite_ini_fini_test_run (errmsg, errflg) - - use GFS_typedefs, only: GFS_interstitial_type - - implicit none - - ! interface variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - write(errmsg,'(a)') "DH ERROR: GFS_suite_ini_fini_test_run should not be called" - errflg = 1 - - end subroutine GFS_suite_ini_fini_test_run - - end module GFS_suite_ini_fini_test diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 deleted file mode 100644 index 4fecabad5..000000000 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ /dev/null @@ -1,141 +0,0 @@ -!> \file GFS_time_vary_pre.F90 -!! Contains code related to GFS physics suite setup (generic part of time_vary_step) - - module GFS_time_vary_pre - - use funcphys, only: gfuncphys - - implicit none - - private - - public GFS_time_vary_pre_init, GFS_time_vary_pre_run, GFS_time_vary_pre_finalize - - logical :: is_initialized = .false. - - contains - -!> \section arg_table_GFS_time_vary_pre_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_time_vary_pre_init (errmsg, errflg) - - implicit none - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (is_initialized) return - - !--- Call gfuncphys (funcphys.f) to compute all physics function tables. - call gfuncphys () - - is_initialized = .true. - - end subroutine GFS_time_vary_pre_init - - -!> \section arg_table_GFS_time_vary_pre_finalize Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_time_vary_pre_finalize(errmsg, errflg) - - implicit none - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. is_initialized) return - - ! DH* this is the place to deallocate whatever is allocated by gfuncphys() in GFS_time_vary_pre_init - - is_initialized = .false. - - end subroutine GFS_time_vary_pre_finalize - - -!> \section arg_table_GFS_time_vary_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type - - implicit none - - type(GFS_control_type), intent(inout) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys - real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys - real(kind=kind_phys) :: rinc(5) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Check initialization status - if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" - errflg = 1 - return - end if - - !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 - !--- update calendars and triggers - rinc(1:5) = 0 - call w3difdat(Model%jdat,Model%idat,4,rinc) - Model%sec = rinc(4) - Model%phour = Model%sec/con_hr - !--- set current bucket hour - Model%zhour = Model%phour - Model%fhour = (Model%sec + Model%dtp)/con_hr - Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) - - Model%ipt = 1 - Model%lprnt = .false. - Model%lssav = .true. - - !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) - - !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) - - if ((Model%debug) .and. (Model%me == Model%master)) then - print *,' sec ', Model%sec - print *,' kdt ', Model%kdt - print *,' nsswr ', Model%nsswr - print *,' nslwr ', Model%nslwr - print *,' nscyc ', Model%nscyc - print *,' lsswr ', Model%lsswr - print *,' lslwr ', Model%lslwr - print *,' fhour ', Model%fhour - print *,' phour ', Model%phour - print *,' solhr ', Model%solhr - endif - - end subroutine GFS_time_vary_pre_run - - end module GFS_time_vary_pre diff --git a/physics/cu_ntiedtke.F90 b/physics/cu_ntiedtke.F90 deleted file mode 100644 index 954c4a65f..000000000 --- a/physics/cu_ntiedtke.F90 +++ /dev/null @@ -1,3840 +0,0 @@ -!> \file cu_ntiedtke.F90 -!! This file contains the CCPP-compliant new Tiedtke scheme which parameterize -!! Shallow, deep, and mid-level convections in the model -!! Please refer to Tiedtke (1989), Bechtold et al. (2004,2008, 2014), -!! Zhang et al. (2011), Zhang and Wang (2017, 2018) -!! -!########################################################### - -module cu_ntiedtke - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - use machine , only : kind_phys - ! DH* TODO - replace with arguments to subroutine calls, - ! this also requires redefining derived constants in the - ! parameter section below - use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & - & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus - - implicit none - real(kind=kind_phys),private :: rcpd,vtmpc1,tmelt,als,t13, & - c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg - - real(kind=kind_phys),private :: rovcp,r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice - real(kind=kind_phys),private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon - integer,private :: momtrans,p650 - - parameter( & - t13 = 0.333333333,& - 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, & - als = alv+alf, & - 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, & - rovcp = rd*rcpd ) -! -! 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 ) -! ------- -! - logical :: isequil -! isequil: representing equilibrium and nonequilibrium convection -! ( .false. [default]; .true. [experimental]. Ref. Bechtold et al. 2014 JAS ) -! - parameter(isequil = .false. ) -! -!-------------------- -! switches for deep, mid, shallow convections, downdraft, and momemtum transport -! ------------------ - logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv - parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) -!-------------------- -!#################### end of variables definition########################## -!----------------------------------------------------------------------- -! -contains -!> \brief Brief description of the subroutine -!! -!! \section arg_table_cu_ntiedtke_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| -!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine cu_ntiedtke_init(mpirank, mpiroot, errmsg, errflg) - - implicit none - - integer, intent(in) :: mpirank - integer, intent(in) :: mpiroot - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! initialize ccpp error handling variables - errmsg = '' - errflg = 0 - - ! DH* temporary - if (mpirank==mpiroot) then - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING --- the CCPP New Tiedtke convection scheme is currently under development, use at your own risk --- WARNING ---' - write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' - end if - ! *DH temporary - - end subroutine cu_ntiedtke_init - - -!> \brief Brief description of the subroutine -!! -!! \section arg_table_cu_ntiedtke_finalize Argument Table -!! - subroutine cu_ntiedtke_finalize() - end subroutine cu_ntiedtke_finalize -! -! Tiedtke cumulus scheme from WRF with small modifications -! This scheme includes both deep and shallow convections -!=================== -! -!! -!! \section arg_table_cu_ntiedtke_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------|----------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | pu | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | -!! | pv | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | -!! | pt | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | -!! | pqv | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | pqvf | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | -!! | ptf | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | -!! | clw | convective_transportable_tracers | array to contain cloud water and other tracers | kg kg-1 | 3 | real | kind_phys | inout | F | -!! | poz | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | -!! | pzz | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | pomg | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | hfx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | zprecc | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | -!! | lmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | -!! | lq | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | -!! | kbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | -!! | ktop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | -!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | -!! | ktrac | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | -!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | -!! | cnvw | convective_cloud_water_mixing_ratio | convective cloud water | kg kg-1 | 2 | real | kind_phys | out | F | -!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!----------------------------------------------------------------------- -! level 1 subroutine 'tiecnvn' -!----------------------------------------------------------------- - subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqvf,ptf,clw,poz,pzz,prsl,prsi,pomg, & - evap,hfx,zprecc,lmask,lq,ix,km,dt,dx,kbot,ktop,kcnv,& - ktrac,ud_mf,dd_mf,dt_mf,cnvw,cnvc,errmsg,errflg) -!----------------------------------------------------------------- -! this is the interface between the model and the mass -! flux convection module -!----------------------------------------------------------------- - implicit none -! in&out variables - integer, intent(in) :: lq, ix, km, ktrac - real(kind=kind_phys), intent(in ) :: dt - integer, dimension( lq ), intent(in) :: lmask - real(kind=kind_phys), dimension( lq ), intent(in ) :: evap, hfx, dx - real(kind=kind_phys), dimension( ix , km ), intent(inout) :: pu, pv, pt, pqv - real(kind=kind_phys), dimension( ix , km ), intent(in ) :: poz, prsl, pomg, pqvf, ptf - real(kind=kind_phys), dimension( ix , km+1 ), intent(in ) :: pzz, prsi - real(kind=kind_phys), dimension( ix , km, ktrac+2 ), intent(inout ) :: clw - - integer, dimension( lq ), intent(out) :: kbot, ktop, kcnv - real(kind=kind_phys), dimension( lq ), intent(out) :: zprecc - real(kind=kind_phys), dimension (lq,km), intent(out) :: ud_mf, dd_mf, dt_mf, cnvw, cnvc - -! error messages - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! local variables - real(kind=kind_phys) 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,km+1) - real(kind=kind_phys) pqhfl(lq), zqq(lq,km), & - & prsfc(lq), pssfc(lq), pcte(lq,km), & - & phhfl(lq), pgeoh(lq,km+1) - real(kind=kind_phys) ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km),& - & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), zmfude_rate(lq,km),& - & zqsat(lq,km), zrain(lq) - real(kind=kind_phys) pcen(lq,km,ktrac),ptenc(lq,km,ktrac) - - integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) - logical locum(lq) -! - real(kind=kind_phys) ztmst,fliq,fice,ztc,zalf,tt - integer i,j,k,k1,n,km1 - real(kind=kind_phys) ztpp1 - real(kind=kind_phys) zew,zqs,zcor -! -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - km1 = km + 1 - 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)=pzz(j,1) - paph(j,km1)=prsi(j,1) - if(lmask(j).eq.1) then - lndj(j)=1 - else - lndj(j)=0 - end if - end do -! -! convert model variables for mflux scheme -! - do k=1,km - k1=km-k+1 - do j=1,lq - pcte(j,k1)=0.0 - pvom(j,k1)=0.0 - pvol(j,k1)=0.0 - ztp1(j,k1)=pt(j,k) - zqp1(j,k1)=pqv(j,k) - pum1(j,k1)=pu(j,k) - pvm1(j,k1)=pv(j,k) - pverv(j,k1)=pomg(j,k) - pgeo(j,k1)=poz(j,k) - pgeoh(j,k1)=pzz(j,k+1) - pap(j,k1)=prsl(j,k) - paph(j,k1)=prsi(j,k+1) - tt=ztp1(j,k1) - zew = foeewm(tt) - zqs = zew/pap(j,k1) - zqs = min(0.5,zqs) - zcor = 1./(1.-vtmpc1*zqs) - zqsat(j,k1)=zqs*zcor - pqte(j,k1)=pqvf(j,k) - zqq(j,k1) =pqte(j,k1) - ptte(j,k1)=ptf(j,k) - ztt(j,k1) =ptte(j,k1) - ud_mf(j,k1)=0. - dd_mf(j,k1)=0. - dt_mf(j,k1)=0. - cnvw(j,k1)=0. - cnvc(j,k1)=0. - end do - end do - - do n=1,ktrac - do k=1,km - k1=km-k+1 - do j=1,lq - pcen(j,k1,n) = clw(j,k,n+2) - ptenc(j,k1,n)= 0. - end do - end do - end do - -! print *, "pgeo=",pgeo(1,:) -! print *, "pgeoh=",pgeoh(1,:) -! print *, "pap=",pap(1,:) -! print *, "paph=",paph(1,:) -! print *, "ztp1=",ztp1(1,:) -! print *, "zqp1=",zqp1(1,:) -! print *, "pum1=",pum1(1,:) -! print *, "pvm1=",pvm1(1,:) -! print *, "pverv=",pverv(1,:) -! print *, "pqte=",pqte(1,:) -! print *, "ptte=",ptte(1,:) -! print *, "hfx=", pqhfl(1),phhfl(1),dx(1) -! -!----------------------------------------------------------------------- -!* 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, ktrac, pcen, ptenc,& - & ktype, icbot, ictop, ztu, zqu, & - & zlu, zlude, zmfu, zmfd, zrain,& - & pcte, phhfl, lndj, pgeoh, zmfude_rate, dx) -! -! to include the cloud water and cloud ice detrained from convection -! - do k=1,km - k1=km-k+1 - do j=1,lq - if(pcte(j,k1).gt.0.) then - fliq=foealfa(ztp1(j,k1)) - fice=1.0-fliq - clw(j,k,2)=clw(j,k,2)+fliq*pcte(j,k1)*ztmst - clw(j,k,1)=clw(j,k,1)+fice*pcte(j,k1)*ztmst - endif - end do - end do -! - do k=1,km - k1 = km-k+1 - do j=1,lq - pt(j,k) = ztp1(j,k1)+(ptte(j,k1)-ztt(j,k1))*ztmst - pqv(j,k)= zqp1(j,k1)+(pqte(j,k1)-zqq(j,k1))*ztmst - ud_mf(j,k)= zmfu(j,k1)*ztmst - dd_mf(j,k)= zmfd(j,k1)*ztmst - dt_mf(j,k)= zmfude_rate(j,k1)*ztmst - cnvw(j,k) = zlude(j,k1)*ztmst*g/(prsi(j,k)-prsi(j,k+1)) - cnvc(j,k) = 0.04 * log(1. + 675. * ud_mf(j,k)) - cnvc(j,k) = min(cnvc(j,k), 0.6) - cnvc(j,k) = max(cnvc(j,k), 0.0) - end do - end do - - do j=1,lq - zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst*0.001) - kbot(j) = km-icbot(j)+1 - ktop(j) = km-ictop(j)+1 - if(ktype(j).eq.1 .or. ktype(j).eq.3) then - kcnv(j)=1 - else - kcnv(j)=0 - end if - end do - - if (lmfdudv) then - do k=1,km - k1=km-k+1 - do j=1,lq - pu(j,k)=pu(j,k)+pvom(j,k1)*ztmst - pv(j,k)=pv(j,k)+pvol(j,k1)*ztmst - end do - end do - endif -! - if (ktrac > 0) then - do n=1,ktrac - do k=1,km - k1=km-k+1 - do j=1,lq - clw(j,k,n+2)=pcen(j,k,n)+ptenc(j,k1,n)*ztmst - end do - end do - end do - end if -! - 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, ktrac, pcen, ptenc,& - & ktype, kcbot, kctop, ptu, pqu,& - & plu, plude, pmfu, pmfd, prain,& - & pcte, phhfl, lndj, zgeoh, pmfude_rate, dx) - 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,ktrac,klevp1,klevm1 - real(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pmflxr(klon,klevp1), pmflxs(klon,klevp1) - real(kind=kind_phys) zhcbase(klon),& - & zmfub(klon), zmfub1(klon),& - & zdhpbl(klon) - real(kind=kind_phys) zsfl(klon), zdpmel(klon,klev),& - & pcte(klon,klev), zcape(klon),& - & zcape1(klon), zcape2(klon),& - & ztauc(klon), ztaubl(klon),& - & zheat(klon) - real(kind=kind_phys) pcen(klon,klev,ktrac), ptenc(klon,klev,ktrac) - real(kind=kind_phys) wup(klon), zdqcv(klon) - real(kind=kind_phys) wbase(klon), zmfuub(klon) - real(kind=kind_phys) upbl(klon) - real(kind=kind_phys) dx(klon) - real(kind=kind_phys) pmfude_rate(klon,klev), pmfdde_rate(klon,klev) - real(kind=kind_phys) zmfuus(klon,klev), zmfdus(klon,klev) - real(kind=kind_phys) zmfudr(klon,klev), zmfddr(klon,klev) - real(kind=kind_phys) zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) - real(kind=kind_phys) 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), lldcum(klon) - logical loddraf(klon), llddraf3(klon), llo1, llo2(klon) - -! local varaiables - 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 - integer jl,jk,ik - integer ikb,ikt,icum,itopm2 - real(kind=kind_phys) ztmst,ztau,zerate,zderate,zmfa - real(kind=kind_phys) zmfs(klon),pmean(klev),zlon - real(kind=kind_phys) zduten,zdvten,ztdis,pgf_u,pgf_v -!------------------------------------------- -! 1. specify constants and parameters -!------------------------------------------- - zcons=1./(g*ztmst) - zcons2=3./(g*ztmst) - - zlon = real(klon) - do jk = klev , 1 , -1 - pmean(jk) = sum(pap(:,jk))/zlon - end do - p650 = klev-2 - do jk = klev , 3 , -1 - if ( pmean(jk)/pmean(klev)*1.013250e5 > 650.e2 ) p650 = jk - end do - -!-------------------------------------------------------------- -!* 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) - ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) - ztau = max(ztmst,ztau) - ztau = max(720.,ztau) - ztau = min(10800.,ztau) - if(isequil) 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) = 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 - - itopm2 = 2 -!---------------------------------------------------------- -!* 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 - if(ktype(jl) == 1 .or. ktype(jl) == 3) then - pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - else - pgf_u = 0. - pgf_v = 0. - end if - 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 - - !---------------------------------------------------------------------- - !* 11.0 CHEMICAL TRACER TRANSPORT - ! ------------------------- - - if ( ktrac > 0 ) then - ! transport switched off for mid-level convection - do jl = 1, klon - if ( ldcum(jl) .and. ktype(jl) /= 3 .and. & - kcbot(jl)-kctop(jl) >= 1 ) then - lldcum(jl) = .true. - llddraf3(jl) = loddraf(jl) - else - lldcum(jl) = .false. - llddraf3(jl) = .false. - end if - end do - ! check and correct mass fluxes for CFL criterium - zmfs(:) = 1. - do jk = 2 , klev - do jl = 1, klon - if ( lldcum(jl) .and. jk >= kctop(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*0.8*zcons - if ( pmfu(jl,jk) > zmfmax ) 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 - if ( lldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfudr(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) - else - zmfuus(jl,jk) = 0. - zmfudr(jl,jk) = 0. - end if - if ( llddraf3(jl) .and. jk >= idtop(jl)-1 ) then - zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) - zmfddr(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) - else - zmfdus(jl,jk) = 0. - zmfddr(jl,jk) = 0. - end if - end do - end do - - call cuctracer(klon,klev,ktrac,kctop,idtop, & - lldcum,llddraf3,ztmst,paph,zmfuus,zmfdus, & - zmfudr,zmfddr,pcen,ptenc) - 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pten(klon,klev) - real(kind=kind_phys) ptu(klon,klev),pqu(klon,klev),plu(klon,klev) - real(kind=kind_phys) pgeo(klon,klev) - integer klab(klon,klev) - integer kctop(klon),kcbot(klon) - - real(kind=kind_phys) qfx(klon),hfx(klon) - real(kind=kind_phys) zph(klon) - integer lndj(klon) - logical loflag(klon), deepflag(klon), resetflag(klon) - -! output variables - real(kind=kind_phys) cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) - integer culab(klon,klev) - real(kind=kind_phys) wbase(klon) - integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) - logical ldcum(klon) - -! local variables - real(kind=kind_phys) zqold(klon) - real(kind=kind_phys) rho, part1, part2, root, conw, deltt, deltq - real(kind=kind_phys) eta(klon),dz(klon),coef(klon) - real(kind=kind_phys) dhen(klon,klev), dh(klon,klev) - real(kind=kind_phys) plude(klon,klev) - real(kind=kind_phys) kup(klon,klev) - real(kind=kind_phys) vptu(klon,klev),vten(klon,klev) - real(kind=kind_phys) zbuo(klon,klev),abuoy(klon,klev) - - 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 - integer nk,is,ikb,ikt - - real(kind=kind_phys) zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp - real(kind=kind_phys) 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)))) - hfx(jl) = hfx(jl)*rho*cpd - qfx(jl) = qfx(jl)*rho - 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.55/(pgeo(jl,jk)*zrg)+1.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,klevm1-20,-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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) zdmfen(klon), zdmfde(klon),& - & zmfuu(klon), zmfuv(klon),& - & zpbase(klon), zqold(klon) - real(kind=kind_phys) phcbase(klon), zluold(klon) - real(kind=kind_phys) zprecip(klon), zlrain(klon,klev) - real(kind=kind_phys) zbuo(klon,klev), kup(klon,klev) - real(kind=kind_phys) wup(klon) - real(kind=kind_phys) wbase(klon), zodetr(klon,klev) - real(kind=kind_phys) plglac(klon,klev) - - real(kind=kind_phys) 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(kind=kind_phys) zoentr(klon), zdpmean(klon) - real(kind=kind_phys) 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(kind=kind_phys) ztmst,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 -!-------------------------------- -!* 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) !* (1.6-min(1.,pqen(jl,jk) / & - ! pqsen(jl,jk))) - 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 -! if ((paph(jl,ikb)-paph(jl,jk))>zdnoprc) 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(kind=kind_phys)): - -! *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(kind=kind_phys)): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real(kind=kind_phys)): - -! *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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys)): - -! *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(kind=kind_phys)): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real(kind=kind_phys)): - -! *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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pmfdde_rate(klon,klev) - logical lddraf(klon) - - real(kind=kind_phys) zdmfen(klon), zdmfde(klon), & - & zcond(klon), zoentr(klon), & - & zbuoy(klon) - real(kind=kind_phys) zph(klon) - logical llo2(klon) - logical llo1 -! local variables - integer jl,jk - integer is,ik,icall,ike, itopde(klon) - real(kind=kind_phys) zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp - real(kind=kind_phys) 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(kind=kind_phys)): - -! *ztmst* 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(kind=kind_phys) ztmst - real(kind=kind_phys) paph(klon,klev+1), pgeoh(klon,klev+1) - real(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) ptent(klon,klev), ptenq(klon,klev) - real(kind=kind_phys) pcte(klon,klev) - -! local variables - integer jk , ik , jl - real(kind=kind_phys) zalv , zzp - real(kind=kind_phys) 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(kind=kind_phys) ztmst - real(kind=kind_phys) paph(klon,klev+1) - real(kind=kind_phys) 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(kind=kind_phys) ptenu(klon,klev), ptenv(klon,klev) - -!local variables - real(kind=kind_phys) zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & - zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) - - integer ik , ikb , jk , jl - real(kind=kind_phys) zzp, zdtdt - - real(kind=kind_phys) 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 cuctracer(klon,klev,ktrac,kctop,kdtop, & - ldcum,lddraf,ztmst,paph,pmfu,pmfd, & - pudrate,pddrate,pcen,ptenc) - implicit none - integer klon,klev,ktrac - integer kctop(klon), kdtop(klon) - logical ldcum(klon), lddraf(klon) - real(kind=kind_phys) ztmst - real(kind=kind_phys) paph(klon,klev+1) - real(kind=kind_phys) pmfu(klon,klev) - real(kind=kind_phys) pmfd(klon,klev) - real(kind=kind_phys) pudrate(klon,klev) - real(kind=kind_phys) pddrate(klon,klev) - real(kind=kind_phys) pcen(klon,klev,ktrac) - real(kind=kind_phys) ptenc(klon,klev,ktrac) - !---------------------------------------------------------------------- - integer ik , jk , jl , jn - real(kind=kind_phys) zzp , zmfa , zerate , zposi - ! ALLOCATABLE ARAYS - real(kind=kind_phys) , dimension(:,:,:) , allocatable :: zcen , zcu , zcd , & - ztenc , zmfc - real(kind=kind_phys) , dimension(:,:) , allocatable :: zdp - logical , dimension(:,:) , allocatable :: llcumask , llcumbas - !---------------------------------------------------------------------- - allocate (zcen(klon,klev,ktrac)) ! Half-level environmental values - allocate (zcu(klon,klev,ktrac)) ! Updraft values - allocate (zcd(klon,klev,ktrac)) ! Downdraft values - allocate (ztenc(klon,klev,ktrac)) ! Tendency - allocate (zmfc(klon,klev,ktrac)) ! Fluxes - allocate (zdp(klon,klev)) ! Pressure difference - allocate (llcumask(klon,klev)) ! Mask for convection - ! Initialize Cumulus mask + some setups - do jk = 2, klev - do jl = 1, klon - llcumask(jl,jk) = .false. - if ( ldcum(jl) ) then - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - if ( jk >= kctop(jl)-1 ) llcumask(jl,jk) = .true. - end if - end do - end do - !---------------------------------------------------------------------- - do jn = 1 , ktrac - !* 1.0 DEFINE TRACERS AT HALF LEVELS - ! ----------------------------- - do jk = 2 , klev - ik = jk - 1 - do jl = 1, klon - zcen(jl,jk,jn) = pcen(jl,jk,jn) - zcd(jl,jk,jn) = pcen(jl,ik,jn) - zcu(jl,jk,jn) = pcen(jl,ik,jn) - zmfc(jl,jk,jn) = 0. - ztenc(jl,jk,jn)= 0. - end do - end do - - do jl = 1, klon - zcu(jl,klev,jn) = pcen(jl,klev,jn) - end do - !* 2.0 COMPUTE UPDRAFT VALUES - ! ---------------------- - do jk = klev - 1 , 3 , -1 - ik = jk + 1 - do jl = 1, klon - if ( llcumask(jl,jk) ) then - zerate = pmfu(jl,jk) - pmfu(jl,ik) + pudrate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - if ( jk >= kctop(jl) ) then - zcu(jl,jk,jn) = (pmfu(jl,ik)*zcu(jl,ik,jn) + & - zerate*pcen(jl,jk,jn)-pudrate(jl,jk)*zcu(jl,ik,jn))*zmfa - end if - end if - end do - end do - !* 3.0 COMPUTE DOWNDRAFT VALUES - ! ------------------------ - do jk = 3 , klev - ik = jk - 1 - do jl = 1, klon - if ( lddraf(jl) .and. jk == kdtop(jl) ) then - ! Nota: in order to avoid final negative Tracer values at LFS - ! the allowed value of ZCD depends on the jump in mass flux - ! at the LFS - zcd(jl,jk,jn) = 0.1*zcu(jl,jk,jn) + 0.9*pcen(jl,ik,jn) - else if ( lddraf(jl).and.jk>kdtop(jl) ) then - zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pddrate(jl,jk) - zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) - zcd(jl,jk,jn) = (pmfd(jl,ik)*zcd(jl,ik,jn) - & - zerate*pcen(jl,ik,jn)+pddrate(jl,jk)*zcd(jl,ik,jn))*zmfa - end if - end do - end do - ! In order to avoid negative Tracer at KLEV adjust ZCD - jk = klev - ik = jk - 1 - do jl = 1, klon - if ( lddraf(jl) ) then - zposi = -zdp(jl,jk) *(pmfu(jl,jk)*zcu(jl,jk,jn) + & - pmfd(jl,jk)*zcd(jl,jk,jn)-(pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn)) - if ( pcen(jl,jk,jn)+zposi*ztmst < 0. ) then - zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) - zcd(jl,jk,jn) = ((pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn) - & - pmfu(jl,jk)*zcu(jl,jk,jn)+pcen(jl,jk,jn) / & - (ztmst*zdp(jl,jk)))*zmfa - end if - end if - end do - end do - !---------------------------------------------------------------------- - do jn = 1 , ktrac - !* 4.0 COMPUTE FLUXES - ! -------------- - do jk = 2 , klev - ik = jk - 1 - do jl = 1, klon - if ( llcumask(jl,jk) ) then - zmfa = pmfu(jl,jk) + pmfd(jl,jk) - zmfc(jl,jk,jn) = pmfu(jl,jk)*zcu(jl,jk,jn) + & - pmfd(jl,jk)*zcd(jl,jk,jn) - zmfa*zcen(jl,ik,jn) - end if - end do - end do - !* 5.0 COMPUTE TENDENCIES = RHS - ! ------------------------ - do jk = 2 , klev - 1 - ik = jk + 1 - do jl = 1, klon - if ( llcumask(jl,jk) ) then - ztenc(jl,jk,jn) = zdp(jl,jk)*(zmfc(jl,ik,jn)-zmfc(jl,jk,jn)) - end if - end do - end do - jk = klev - do jl = 1, klon - if ( ldcum(jl) ) ztenc(jl,jk,jn) = -zdp(jl,jk)*zmfc(jl,jk,jn) - end do - end do - !* 6.0 UPDATE TENDENCIES - ! ----------------- - do jn = 1, ktrac - do jk = 2, klev - do jl = 1, klon - if ( llcumask(jl,jk) ) then - ptenc(jl,jk,jn) = ptenc(jl,jk,jn)+ztenc(jl,jk,jn) - end if - end do - end do - end do - !--------------------------------------------------------------------------- - deallocate (llcumask) - deallocate (zdp) - deallocate (zmfc) - deallocate (ztenc) - deallocate (zcd) - deallocate (zcu) - deallocate (zcen) - end subroutine cuctracer - -!--------------------------------------------------------- -! level 4 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(kind=kind_phys)): - -! *psp* pressure pa - -! updated parameters (real(kind=kind_phys)): - -! *pt* temperature k -! *pq* specific humidity kg/kg -! externals -! --------- -! for condensation calculations. -! the tables are initialised in *suphec*. - -!---------------------------------------------------------------------- - - implicit none - - integer klev,klon - real(kind=kind_phys) pt(klon,klev), pq(klon,klev), & - & psp(klon) - logical ldflag(klon) -! local variables - integer jl,jk - integer isum,kcall,kk - 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 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(kind=kind_phys) 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(kind=kind_phys) 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(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 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(kind=kind_phys) pgeoh(klon,klev+1) - real(kind=kind_phys) pmfu(klon,klev) - real(kind=kind_phys) pdmfen(klon) - real(kind=kind_phys) pdmfde(klon) - logical llo1 - integer jl - real(kind=kind_phys) zdz , zmf - real(kind=kind_phys) 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(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) 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) 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) 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) 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) tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm - - real(kind=kind_phys) function foeldcp(tt) - implicit none - real(kind=kind_phys) tt - foeldcp = foedelta(tt)*ralvdcp + (1.-foedelta(tt))*ralsdcp - end function foeldcp - - real(kind=kind_phys) function foedelta(tt) - implicit none - real(kind=kind_phys) tt - foedelta = max(0.,sign(1.,tt-tmelt)) - end function foedelta - -end module cu_ntiedtke - diff --git a/physics/cu_ntiedtke_post.F90 b/physics/cu_ntiedtke_post.F90 deleted file mode 100644 index fdc0b8b0f..000000000 --- a/physics/cu_ntiedtke_post.F90 +++ /dev/null @@ -1,53 +0,0 @@ -!> \file cu_ntiedtke_post.F90 -!! Contains code related to New Tiedtke convective scheme - -module cu_ntiedtke_post - - implicit none - - private - - public :: cu_ntiedtke_post_init, cu_ntiedtke_post_run, cu_ntiedtke_post_finalize - - contains - - subroutine cu_ntiedtke_post_init () - end subroutine cu_ntiedtke_post_init - - subroutine cu_ntiedtke_post_finalize() - end subroutine cu_ntiedtke_post_finalize - -!> \section arg_table_cu_ntiedtke_post_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | t | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | in | F | -!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | -!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | out | F | -!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine cu_ntiedtke_post_run (t, q, prevst, prevsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(out) :: prevst(:,:) - real(kind_phys), intent(out) :: prevsq(:,:) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - prevst(:,:) = t(:,:) - prevsq(:,:) = q(:,:) - - end subroutine cu_ntiedtke_post_run - -end module cu_ntiedtke_post diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/cu_ntiedtke_pre.F90 deleted file mode 100644 index 725b4a351..000000000 --- a/physics/cu_ntiedtke_pre.F90 +++ /dev/null @@ -1,84 +0,0 @@ -!> \file cu_ntiedtke_pre.F90 -!! Contains code related to New Tiedtke convective scheme - -module cu_ntiedtke_pre - - implicit none - - private - - public :: cu_ntiedtke_pre_init, cu_ntiedtke_pre_run, cu_ntiedtke_pre_finalize - - contains - - subroutine cu_ntiedtke_pre_init () - end subroutine cu_ntiedtke_pre_init - - subroutine cu_ntiedtke_pre_finalize() - end subroutine cu_ntiedtke_pre_finalize - -!> \section arg_table_cu_ntiedtke_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | -!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | -!! | fhour | forecast_time | curent forecast time | h | 0 | real | kind_phys | in | F | -!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | -!! | t | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | -!! | q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | in | F | -!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | in | F | -!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | out | F | -!! | forceq | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine cu_ntiedtke_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & - forcet, forceq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - logical, intent(in) :: flag_init - logical, intent(in) :: flag_restart - integer, intent(in) :: kdt - real(kind_phys), intent(in) :: fhour - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in) :: t(:,:) - real(kind_phys), intent(in) :: q(:,:) - real(kind_phys), intent(in) :: prevst(:,:) - real(kind_phys), intent(in) :: prevsq(:,:) - real(kind_phys), intent(out) :: forcet(:,:) - real(kind_phys), intent(out) :: forceq(:,:) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys) :: dtdyn - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! For restart runs, can assume that prevst and prevsq - ! are read from the restart files beforehand, same - ! for conv_act. - if(flag_init .and. .not.flag_restart) then - forcet(:,:)=0.0 - forceq(:,:)=0.0 - else - dtdyn=3600.0*(fhour)/kdt - if(dtp > dtdyn) then - forcet(:,:)=(t(:,:) - prevst(:,:))/dtp - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp - else - forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn - forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn - endif - endif - - end subroutine cu_ntiedtke_pre_run - -end module cu_ntiedtke_pre diff --git a/physics/gcm_shoc.F90 b/physics/gcm_shoc.F90 deleted file mode 100644 index f2c9b7a7b..000000000 --- a/physics/gcm_shoc.F90 +++ /dev/null @@ -1,2040 +0,0 @@ -!> \file gcm_shoc.F90 -!! Contains the Simplified Higher-Order Closure (SHOC) scheme. - -!> This module contains the CCPP-compliant SHOC scheme. -module shoc - use machine, only: kind_phys - - implicit none - - private - - public shoc_run, shoc_init, shoc_finalize - -contains - -subroutine shoc_init () -end subroutine shoc_init - -subroutine shoc_finalize () -end subroutine shoc_finalize - -#if 0 -!> \section arg_table_shoc_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------------------|-----------------------------------------------------------------------------|---------------------------------------------------------------------------------------------|---------------|------|------------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | nx | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | nzm | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | -!! | shocaftcnv | flag_for_shoc_after_convection | flag to execute SHOC after convection | flag | 0 | logical | | in | F | -!! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | -!! | imp_physics | flag_for_microphysics_scheme | choice of microphysics scheme | flag | 0 | integer | | in | F | -!! | imp_physics_gfdl | flag_for_gfdl_microphysics_scheme | choice of GFDL microphysics scheme | flag | 0 | integer | | in | F | -!! | imp_physics_zhao_carr | flag_for_zhao_carr_microphysics_scheme | choice of Zhao-Carr microphysics scheme | flag | 0 | integer | | in | F | -!! | imp_physics_zhao_carr_pdf | flag_for_zhao_carr_pdf_microphysics_scheme | choice of Zhao-Carr microphysics scheme with PDF clouds | flag | 0 | integer | | in | F | -!! | imp_physics_mg | flag_for_morrison_gettelman_microphysics_scheme | choice of Morrison-Gettelman rmicrophysics scheme | flag | 0 | integer | | in | F | -!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | -!! | tcr | cloud_phase_transition_threshold_temperature | threshold temperature below which cloud starts to freeze | K | 0 | real | kind_phys | in | F | -!! | tcrf | cloud_phase_transition_denominator | denominator in cloud phase transition = 1/(tcr-tf) | K-1 | 0 | real | kind_phys | in | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | -!! | con_hfus | latent_heat_of_fusion_of_water_at_0C | latent heat of fusion | J kg-1 | 0 | real | kind_phys | in | F | -!! | con_rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | -!! | con_fvirt | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | gq0_cloud_ice | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | -!! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | -!! | gq0_snow | snow_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of snow water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | -!! | gq0_graupel | graupel_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of graupel updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | -!! | dtp | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | -!! | u | x_wind_updated_by_physics | zonal wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | -!! | v | y_wind_updated_by_physics | meridional wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | -!! | omega | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | -!! | rhc | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | -!! | supice | ice_supersaturation_threshold | ice supersaturation parameter for PDF clouds | none | 0 | real | kind_phys | in | F | -!! | pcrit | shoc_tke_dissipatation_pressure_threshold | pressure below which extra TKE diss. is applied in SHOC | Pa | 0 | real | kind_phys | in | F | -!! | cefac | shoc_tke_dissipation_tunable_parameter | mult. tuning parameter for TKE diss. in SHOC | none | 0 | real | kind_phys | in | F | -!! | cesfac | shoc_tke_dissipation_tunable_parameter_near_surface | mult. tuning parameter for TKE diss. at surface in SHOC | none | 0 | real | kind_phys | in | F | -!! | tkef1 | shoc_implicit_TKE_integration_uncentering_term | uncentering term for TKE integration in SHOC | none | 0 | real | kind_phys | in | F | -!! | dis_opt | shoc_flag_for_optional_surface_TKE_dissipation | flag for alt. TKE diss. near surface in SHOC (>0 = ON) | none | 0 | real | kind_phys | in | F | -!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | prnum | prandtl_number | turbulent Prandtl number | none | 2 | real | kind_phys | in | F | -!! | skip_macro | flag_skip_macro | flag to skip cloud macrophysics in Morrison scheme | flag | 0 | logical | | inout | F | -!! | clw_ice | ice_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of ice water in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | clw_liquid | cloud_condensed_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | gq0_cloud_liquid | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | ncpl | cloud_droplet_number_concentration_updated_by_physics | number concentration of cloud droplets updated by physics | kg-1 | 2 | real | kind_phys | inout | F | -!! | ncpi | ice_number_concentration_updated_by_physics | number concentration of ice updated by physics | kg-1 | 2 | real | kind_phys | inout | F | -!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | -!! | gq0_water_vapor | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | cld_sgs | subgrid_scale_cloud_fraction_from_shoc | subgrid-scale cloud fraction from the SHOC scheme | frac | 2 | real | kind_phys | inout | F | -!! | tke | turbulent_kinetic_energy_convective_transport_tracer | turbulent kinetic energy in the convectively transported tracer array | m2 s-2 | 2 | real | kind_phys | inout | F | -!! | tkh | atmosphere_heat_diffusivity_from_shoc | diffusivity for heat from the SHOC scheme | m2 s-1 | 2 | real | kind_phys | inout | F | -!! | wthv_sec | kinematic_buoyancy_flux_from_shoc | upward kinematic buoyancy flux from the SHOC scheme | K m s-1 | 2 | real | kind_phys | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -#endif -subroutine shoc_run (ix, nx, nzm, do_shoc, shocaftcnv, mg3_as_mg2, imp_physics, imp_physics_gfdl, imp_physics_zhao_carr, & - imp_physics_zhao_carr_pdf, imp_physics_mg, fprcp, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, & - con_fvirt, gq0_cloud_ice, gq0_rain, gq0_snow, gq0_graupel, dtp, me, prsl, phii, phil, u, v, omega, rhc, supice, pcrit, & - cefac, cesfac, tkef1, dis_opt, hflx, evap, prnum, & - skip_macro, clw_ice, clw_liquid, gq0_cloud_liquid, ncpl, ncpi, gt0, gq0_water_vapor, cld_sgs, tke, tkh, wthv_sec, & - errmsg, errflg) - - implicit none - - integer, intent(in) :: ix, nx, nzm, imp_physics, imp_physics_gfdl, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_mg, fprcp, me - logical, intent(in) :: do_shoc, shocaftcnv, mg3_as_mg2 - real(kind=kind_phys), intent(in) :: tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, con_fvirt, & - dtp, supice, pcrit, cefac, cesfac, tkef1, dis_opt - ! - real(kind=kind_phys), intent(in), dimension(nx) :: hflx, evap - real(kind=kind_phys), intent(in), dimension(nx,nzm) :: gq0_cloud_ice, gq0_rain, gq0_snow, gq0_graupel, prsl, phil, & - u, v, omega, rhc, prnum - real(kind=kind_phys), intent(in), dimension(nx,nzm+1) :: phii - ! - logical, intent(inout) :: skip_macro - real(kind=kind_phys), intent(inout), dimension(nx,nzm) :: clw_ice, clw_liquid, gq0_cloud_liquid, ncpl, ncpi, gt0, & - gq0_water_vapor, cld_sgs, tke, tkh, wthv_sec - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - real(kind=kind_phys), parameter :: epsq = 1.e-20 - - integer :: i, k - - real(kind=kind_phys) :: tem - real(kind=kind_phys), dimension(nx,nzm) :: qsnw ! qsnw can be local to this routine - real(kind=kind_phys), dimension(nx,nzm) :: qgl ! qgl can be local to this routine - -! Initialize CCPP error handling variables - - errmsg = '' - errflg = 0 - - if (shocaftcnv) then - if (imp_physics == imp_physics_mg) then - skip_macro = do_shoc - if (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,nzm - do i=1,nx - !GF - gq0(ntrw) is passed in directly, no need to copy - !qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = 0.0 - enddo - enddo - elseif (fprcp > 1) then - do k=1,nzm - do i=1,nx - !qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k) - qgl(i,k) = 0.0 - enddo - enddo - endif - endif - else - if (imp_physics == imp_physics_mg) then - skip_macro = do_shoc - do k=1,nzm - do i=1,nx - ! DH* THESE ARE NOT IN THE ORIGINAL CODE (AND THEY WERE NEVER) ::: clw_ice(i,k) = gq0_cloud_ice(i,k) ! ice - ! DH* THESE ARE NOT IN THE ORIGINAL CODE (AND THEY WERE NEVER) ::: clw_liquid(i,k) = gq0_cloud_liquid(i,k) ! water - !GF - since gq0(ntlnc/ntinc) are passed in directly, no need to copy - !ncpl(i,k) = Stateout%gq0(i,k,ntlnc) - !ncpi(i,k) = Stateout%gq0(i,k,ntinc) - enddo - enddo - if (abs(fprcp) == 1 .or. mg3_as_mg2) then - do k=1,nzm - do i=1,nx - !GF - gq0(ntrw) is passed in directly, no need to copy - !qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = 0.0 - enddo - enddo - elseif (fprcp > 1) then - do k=1,nzm - do i=1,nx - !qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k) - qgl(i,k) = 0.0 - clw_ice(i,k) = clw_ice(i,k) + gq0_graupel(i,k) - enddo - enddo - endif - elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - needs modify for condensation - do k=1,nzm - do i=1,nx - clw_ice(i,k) = gq0_cloud_ice(i,k) ! ice - clw_liquid(i,k) = gq0_cloud_liquid(i,k) ! water - !qrn(i,k) = gq0_rain(i,k) - qsnw(i,k) = gq0_snow(i,k) - qgl(i,k) = 0.0 - enddo - enddo - elseif (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then - do k=1,nzm - do i=1,nx - if (abs(gq0_cloud_liquid(i,k)) < epsq) then - gq0_cloud_liquid(i,k) = 0.0 - endif - tem = gq0_cloud_liquid(i,k) * max(0.0, MIN(1.0, (tcr-gt0(i,k))*tcrf)) - clw_ice(i,k) = tem ! ice - clw_liquid(i,k) = gq0_cloud_liquid(i,k) - tem ! water - qsnw(i,k) = 0.0 - qgl(i,k) = 0.0 - enddo - enddo - endif - endif !shocaftcnv - - ! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds - ! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients - ! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' - - !GFDL lat has no meaning inside of shoc - changed to "1" - - - ! DH* can we pass in gq0_graupel? is that zero? the original code - ! passes in qgl which is zero (always? sometimes?), in shoc_work - ! this qgl gets added to qpi, qpi = qpi_i + qgl with qpi_i = qsnw; - ! - with the above qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k), - ! would that be double counting? *DH - call shoc_work (ix, nx, 1, nzm, nzm+1, dtp, me, 1, prsl, & - phii, phil, u, v, omega, gt0, & - gq0_water_vapor, clw_ice, clw_liquid, qsnw, gq0_rain, & - qgl, rhc, supice, pcrit, cefac, cesfac, tkef1, dis_opt, & - cld_sgs, tke, hflx, evap, prnum, tkh, wthv_sec, .false., 1, ncpl, ncpi, & - con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, con_fvirt) - - if (.not.shocaftcnv) then - if (imp_physics == imp_physics_mg .and. fprcp > 1) then - do k=1,nzm - do i=1,nx - clw_ice(i,k) = clw_ice(i,k) - gq0_graupel(i,k) - enddo - enddo - endif - endif ! .not. shocaftcnv - - !GF since gq0(ntlnc/ntinc) are passed in directly, no need to copy back - ! if (ntlnc > 0 .and. ntinc > 0 .and. ncld >= 2) then - ! do k=1,nzm - ! do i=1,nx - ! Stateout%gq0(i,k,ntlnc) = ncpl(i,k) - ! Stateout%gq0(i,k,ntinc) = ncpi(i,k) - ! enddo - ! enddo - ! endif - -end subroutine shoc_run - - ! Implementation of the Simplified High Order Closure (SHOC) scheme - ! of Bogenschutz and Krueger (2013), J. Adv. Model. Earth Syst, 5, 195-211, - ! doi: 10.1002/jame.200118. (further referred to as BK13) - ! in a single column form suitable for use in a GCM physics package. - ! Alex Belochitski, heavily based on the code of Peter Bogenschutz. - ! S Moorthi - optimization, cleanup, improve and customize for gsm - ! - improved solution for sgs-tke equation - ! S Moorthi - 05-11-17 - modified shear production term to eliminate - ! spurious tke ove Antarctica. - ! S Moorthi - 01-12-17 - added extra pressure dependent tke dissipation at - ! pressures below a critical value pcrit - ! S Moorthi - 04-12-17 - fixed a bug in the definition of hl on input - ! replacing fac_fus by fac_sub - ! S.Moorthi - 00-00-17 - added an alternate option for near boundary cek following - ! Scipion et. al., from U. Oklahoma. - subroutine shoc_work (ix, nx, ny, nzm, nz, dtn, me, lat, & - prsl, phii, phil, u, v, omega, tabs, & - qwv, qi, qc, qpi_i, qpl, qgl, rhc, supice, & - pcrit, cefac, cesfac, tkef1, dis_opt, & - cld_sgs, tke, hflx, evap, prnum, tkh, & - wthv_sec, lprnt, ipr, ncpl, ncpi, & - cp, ggr, lcond, lfus, rv, rgas, pi, epsv) - - use funcphys , only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice - - implicit none - - real, intent(in) :: cp, ggr, lcond, lfus, rv, rgas, pi, epsv - integer, intent(in) :: ix ! max number of points in the physics window in the x - integer, intent(in) :: nx ! Number of points in the physics window in the x - integer, intent(in) :: ny ! and y directions - integer, intent(in) :: me ! MPI rank - integer, intent(in) :: lat ! latitude - - integer, intent(in) :: nzm ! Number of vertical layers - integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) - real, intent(in) :: dtn ! Physics time step, s - - real, intent(in) :: pcrit ! pressure in Pa below which additional tke dissipation is applied - real, intent(in) :: cefac ! tunable multiplier to dissipation term - real, intent(in) :: cesfac ! tunable multiplier to dissipation term for bottom level - real, intent(in) :: tkef1 ! uncentering terms in implicit tke integration - real, intent(in) :: dis_opt ! when > 0 use different formula for near surface dissipation - - real, intent(in) :: hflx(nx) - real, intent(in) :: evap(nx) - -! The interface is talored to GFS in a sense that input variables are 2D - - real, intent(in) :: prsl (ix,ny,nzm) ! mean layer presure - real, intent(in) :: phii (ix,ny,nz ) ! interface geopotential height - real, intent(in) :: phil (ix,ny,nzm) ! layer geopotential height - real, intent(in) :: u (ix,ny,nzm) ! u-wind, m/s - real, intent(in) :: v (ix,ny,nzm) ! v-wind, m/s - real, intent(in) :: omega (ix,ny,nzm) ! omega, Pa/s - real, intent(inout) :: tabs (ix,ny,nzm) ! temperature, K - real, intent(inout) :: qwv (ix,ny,nzm) ! water vapor mixing ratio, kg/kg - real, intent(inout) :: qc (ix,ny,nzm) ! cloud water mixing ratio, kg/kg - real, intent(inout) :: qi (ix,ny,nzm) ! cloud ice mixing ratio, kg/kg -! Anning Cheng 03/11/2016 SHOC feedback to number concentration - real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 - real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 - real, intent(in) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - not used at this time - real, intent(in) :: qpi_i (nx,ny,nzm) ! snow mixing ratio, kg/kg - not used at this time - real, intent(in) :: qgl (nx,ny,nzm) ! graupel mixing ratio, kg/kg - not used at this time - real, intent(in) :: rhc (nx,ny,nzm) ! critical relative humidity - real, intent(in) :: supice ! ice supersaturation parameter - real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction -! real, intent(inout) :: cld_sgs(nx,ny,nzm) ! sgs cloud fraction - real, intent(inout) :: tke (ix,ny,nzm) ! turbulent kinetic energy. m**2/s**2 -! real, intent(inout) :: tk (nx,ny,nzm) ! eddy viscosity - real, intent(inout) :: tkh (ix,ny,nzm) ! eddy diffusivity - real, intent(in) :: prnum (nx,ny,nzm) ! turbulent Prandtl number - real, intent(inout) :: wthv_sec (ix,ny,nzm) ! Buoyancy flux, K*m/s - - real, parameter :: zero=0.0, one=1.0, half=0.5, two=2.0, eps=0.622, & - three=3.0, oneb3=one/three, twoby3=two/three - real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.0, & - skew_facw=1.2, skew_fact=0.0, & - tkhmax=300.0 - real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, rog, sqrtpii, & - epsterm, onebeps, onebrvcp - -! SHOC tunable parameters - - real, parameter :: lambda = 0.04 -! real, parameter :: min_tke = 1e-6 ! Minumum TKE value, m**2/s**2 - real, parameter :: min_tke = 1e-4 ! Minumum TKE value, m**2/s**2 -! real, parameter :: max_tke = 100.0 ! Maximum TKE value, m**2/s**2 - real, parameter :: max_tke = 40.0 ! Maximum TKE value, m**2/s**2 -! Maximum turbulent eddy length scale, m -! real, parameter :: max_eddy_length_scale = 2000. - real, parameter :: max_eddy_length_scale = 1000. -! Maximum "return-to-isotropy" time scale, s - real, parameter :: max_eddy_dissipation_time_scale = 2000. - real, parameter :: Pr = 1.0 ! Prandtl number - -! Constants for the TKE dissipation term based on Deardorff (1980) - real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01, atmin=0.01, atmax=one-atmin - real, parameter :: Cs = 0.15, epsln=1.0e-6 - real, parameter :: Ck = 0.1 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 - -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 3.0 , Ces = Ce -! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.5 , Ces = Ce * 3.0 / 2.5 -! real, parameter :: Ces = Ce/0.7*3.0 - -! real, parameter :: Ce = Ck**3/(0.7*Cs**4), Ces = Ce*3.0/0.7 ! Commented Moor - - real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce -! real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce*3.0/0.7 - -! real, parameter :: vonk=0.35 ! Von Karman constant - real, parameter :: vonk=0.4 ! Von Karman constant Moorthi - as in GFS - real, parameter :: tscale=400.! time scale set based off of similarity results of BK13, s - real, parameter :: w_tol_sqd = 4.0e-04 ! Min vlaue of second moment of w -! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w - real, parameter :: w_thresh = 0.0, thresh = 0.0 - real, parameter :: w3_tol = 1.0e-20 ! Min vlaue of third moment of w - - -! These parameters are a tie-in with a microphysical scheme -! Double check their values for the Zhao-Carr scheme. - real, parameter :: tbgmin = 233.16 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 258.16 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 253.16 ! Minimum temperature for cloud water., K - real, parameter :: tbgmax = 273.16 ! Maximum temperature for cloud ice, K - real, parameter :: a_bg = one/(tbgmax-tbgmin) -! -! Parameters to tune the second order moments- No tuning is performed currently - - real, parameter :: thl2tune = 1.0, qw2tune = 1.0, qwthl2tune = 1.0, & -! thl_tol = 1.e-4, rt_tol = 1.e-8, basetemp = 300.0 - thl_tol = 1.e-2, rt_tol = 1.e-4, basetemp = 300.0 - - integer, parameter :: nitr=6 - -! Local variables. Note that pressure is in millibars in the SHOC code. - - logical lprnt - integer ipr - - real zl (nx,ny,nzm) ! height of the pressure levels above surface, m - real zi (nx,ny,nz) ! height of the interface levels, m - real adzl (nx,ny,nzm) ! layer thickness i.e. zi(k+1)-zi(k) - defined at levels - real adzi (nx,ny,nz) ! level thickness i.e. zl(k)-zl(k-1) - defined at interface - - real hl (nx,ny,nzm) ! liquid/ice water static energy , K - real qv (nx,ny,nzm) ! water vapor, kg/kg - real qcl (nx,ny,nzm) ! liquid water (condensate), kg/kg - real qci (nx,ny,nzm) ! ice water (condensate), kg/kg - real w (nx,ny,nzm) ! z-wind, m/s - real bet (nx,ny,nzm) ! ggr/tv0 - real gamaz (nx,ny,nzm) ! ggr/cp*z - real qpi (nx,ny,nzm) ! snow + graupel mixing ratio, kg/kg -! real qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - -! Moments of the trivariate double Gaussian PDF for the SGS total water mixing ratio -! SGS liquid/ice static energy, and vertical velocity - - real qw_sec (nx,ny,nzm) ! Second moment total water mixing ratio, kg^2/kg^2 - real thl_sec (nx,ny,nzm) ! Second moment liquid/ice static energy, K^2 - real qwthl_sec(nx,ny,nzm) ! Covariance tot. wat. mix. ratio and static energy, K*kg/kg - real wqw_sec (nx,ny,nzm) ! Turbulent flux of tot. wat. mix., kg/kg*m/s - real wthl_sec (nx,ny,nzm) ! Turbulent flux of liquid/ice static energy, K*m/s - real w_sec (nx,ny,nzm) ! Second moment of vertical velocity, m**2/s**2 - real w3 (nx,ny,nzm) ! Third moment of vertical velocity, m**3/s**3 - real wqp_sec (nx,ny,nzm) ! Turbulent flux of precipitation, kg/kg*m/s - -! Eddy length formulation - real smixt (nx,ny,nzm) ! Turbulent length scale, m - real isotropy (nx,ny,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s -! real isotropy_debug (nx,ny,nzm) ! Return to isotropy scale, s without artificial limits - real brunt (nx,ny,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 - real conv_vel2(nx,ny,nzm) ! Convective velocity scale cubed, m^3/s^3 - - real cek(nx,ny) - -! Output of SHOC - real diag_frac, diag_qn, diag_qi, diag_ql - -! real diag_frac(nx,ny,nzm) ! SGS cloud fraction -! real diag_qn (nx,ny,nzm) ! SGS cloud+ice condensate, kg/kg -! real diag_qi (nx,ny,nzm) ! SGS ice condensate, kg/kg -! real diag_ql (nx,ny,nzm) ! SGS liquid condensate, kg/kg - - -! Horizontally averaged variables -! real conv_vel(nzm) ! Convective velocity scale cubed, m^3/s^3 - real wqlsb (nzm) ! liquid water flux, kg/kg/ m/s - real wqisb (nzm) ! ice flux, kg/kg m/s -! real thlv (nzm) ! Grid-scale level-average virtual potential temperature -! (not used) - - -! Local variables - -! real, dimension(nx,ny,nzm) :: tkesbbuoy, tkesbshear, tkesbdiss, tkesbbuoy_debug & -! tkebuoy_sgs, total_water, tscale1_debug, brunt2 - - real, dimension(nx,ny,nzm) :: total_water, brunt2, thv, tkesbdiss - real, dimension(nx,ny,nzm) :: def2 - real, dimension(nx,ny) :: denom, numer, l_inf, cldarr, thedz, thedz2 - - real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & - conv_var, tkes, skew_w, skew_qw, aterm, w1_1, w1_2, w2_1, & - w2_2, w3var, thl1_1, thl1_2, thl2_1, thl2_2, qw1_1, qw1_2, qw2_1, & - qw2_2, ql1, ql2, w_ql1, w_ql2, & - r_qwthl_1, r_wqw_1, r_wthl_1, testvar, s1, s2, std_s1, std_s2, C1, C2, & - thl_first, qw_first, w_first, Tl1_1, Tl1_2, betatest, pval, pkap, & - w2thl, w2qw,w2ql, w2ql_1, w2ql_2, & - thec, thlsec, qwsec, qwthlsec, wqwsec, wthlsec, thestd,dum, & - cqt1, cthl1, cqt2, cthl2, qn1, qn2, qi1, qi2, omn1, omn2, & - basetemp2, beta1, beta2, qs1, qs2, & - esval1_1, esval2_1, esval1_2, esval2_2, om1, om2, & - lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & - sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & - sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & - corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac - - - integer i,j,k,km1,ku,kd,ka,kb - -!calculate derived constants - lsub = lcond+lfus - fac_cond = lcond/cp - fac_fus = lfus/cp - cpolv = cp/lcond - fac_sub = lsub/cp - ggri = 1.0/ggr - kapa = rgas/cp - gocp = ggr/cp - rog = rgas*ggri - sqrtpii = one/sqrt(pi+pi) - epsterm = rgas/rv - onebeps = one/epsterm - onebrvcp= one/(rv*cp) - -! Map GFS variables to those of SHOC - SHOC operates on 3D fields -! Here a Y-dimension is added to the input variables, along with some unit conversions - - do k=1,nz - do j=1,ny - do i=1,nx - zi(i,j,k) = phii(i,j,k) * ggri - enddo - enddo - enddo - -! if (lprnt) write(0,*)' tabsin=',tabs(ipr,1,1:40) -! if (lprnt) write(0,*)' qcin=',qc(ipr,1,1:40) -! if (lprnt) write(0,*)' qwvin=',qwv(ipr,1,1:40) -! if (lprnt) write(0,*)' qiin=',qi(ipr,1,1:40) -! if (lprnt) write(0,*)' qplin=',qpl(ipr,1,1:40) -! if (lprnt) write(0,*)' qpiin=',qpi(ipr,1,1:40) -! -! move water from vapor to condensate if the condensate is negative -! - do k=1,nzm - do j=1,ny - do i=1,nx - if (qc(i,j,k) < zero) then - wrk = qwv(i,j,k) + qc(i,j,k) - if (wrk >= zero) then - qwv(i,j,k) = wrk - tabs(i,j,k) = tabs(i,j,k) - fac_cond * qc(i,j,k) - qc(i,j,k) = zero - else - qc(i,j,k) = zero - tabs(i,j,k) = tabs(i,j,k) + fac_cond * qwv(i,j,k) - qwv(i,j,k) = zero - endif - endif - if (qi(i,j,k) < zero) then - wrk = qwv(i,j,k) + qi(i,j,k) - if (wrk >= zero) then - qwv(i,j,k) = wrk - tabs(i,j,k) = tabs(i,j,k) - fac_sub * qi(i,j,k) - qi(i,j,k) = zero - else - qi(i,j,k) = zero - tabs(i,j,k) = tabs(i,j,k) + fac_sub * qwv(i,j,k) - qwv(i,j,k) = zero - endif - endif - enddo - enddo - enddo - -! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,1,1:40) - - do k=1,nzm - do j=1,ny - do i=1,nx - zl(i,j,k) = phil(i,j,k) * ggri - wrk = one / prsl(i,j,k) - qv(i,j,k) = max(qwv(i,j,k), zero) - thv(i,j,k) = tabs(i,j,k) * (one+epsv*qv(i,j,k)) - w(i,j,k) = - rog * omega(i,j,k) * thv(i,j,k) * wrk - qcl(i,j,k) = max(qc(i,j,k), zero) - qci(i,j,k) = max(qi(i,j,k), zero) - qpi(i,j,k) = qpi_i(i,j,k) + qgl(i,j,k) ! add snow and graupel together -! -! qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow -! qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow - - wqp_sec(i,j,k) = zero ! Turbulent flux of precipiation -! - total_water(i,j,k) = qcl(i,j,k) + qci(i,j,k) + qv(i,j,k) - - prespot = (100000.0*wrk) ** kapa ! Exner function - bet(i,j,k) = ggr/(tabs(i,j,k)*prespot) ! Moorthi - thv(i,j,k) = thv(i,j,k)*prespot ! Moorthi -! -! Lapse rate * height = reference temperature - gamaz(i,j,k) = gocp * zl(i,j,k) - -! Liquid/ice water static energy - ! Note the the units are degrees K - hl(i,j,k) = tabs(i,j,k) + gamaz(i,j,k) - fac_cond*(qcl(i,j,k)+qpl(i,j,k)) & - - fac_sub *(qci(i,j,k)+qpi(i,j,k)) - w3(i,j,k) = zero - enddo - enddo - enddo - -! if (lprnt) write(0,*)' hlin=',hl(ipr,1,1:40) - -! Define vertical grid increments for later use in the vertical differentiation - - do k=2,nzm - km1 = k - 1 - do j=1,ny - do i=1,nx - adzi(i,j,k) = zl(i,j,k) - zl(i,j,km1) - adzl(i,j,km1) = zi(i,j,k) - zi(i,j,km1) - enddo - enddo - enddo - do j=1,ny - do i=1,nx - adzi(i,j,1) = (zl(i,j,1)-zi(i,j,1)) ! unused in the code - adzi(i,j,nz) = adzi(i,j,nzm) ! at the top - probably unused - adzl(i,j,nzm) = zi(i,j,nz) - zi(i,j,nzm) -! - wthl_sec(i,j,1) = hflx(i) - wqw_sec(i,j,1) = evap(i) - enddo - enddo - - - call tke_shoc() ! Integrate prognostic TKE equation forward in time - - -! diagnose second order moments of the subgrid PDF following -! Redelsperger J.L., and G. Sommeria, 1986, JAS, 43, 2619-2635 sans the use of stabilty -! weighting functions - Result is in global variables w_sec, thl_sec, qw_sec, and qwthl_sec - -! call diag_moments(total_water,tke,tkh) - -! Second moment of vertical velocity. -! Note that Eq 6 in BK13 gives a different expression that is dependent on -! vertical gradient of grid scale vertical velocity - - do k=1,nzm - ku = k+1 - kd = k-1 - ka = ku - kb = k - if (k == 1) then - kd = k - kb = ka - elseif (k == nzm) then - ku = k - ka = kb - endif - do j=1,ny - do i=1,nx - if (tke(i,j,k) > zero) then -! wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & - wrk = half*(tkh(i,j,ka)*prnum(i,j,ka)+tkh(i,j,kb)*prnum(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & - * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) - w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) -! w_sec(i,j,k) = max(twoby3 * tke(i,j,k), zero) -! if(lprnt .and. i == ipr .and. k <40) write(0,*)' w_sec=',w_sec(i,j,k),' tke=r',tke(i,j,k),& -! ' tkh=',tkh(i,j,ka),tkh(i,j,kb),' w=',w(i,j,ku),w(i,j,kd),' prnum=',prnum(i,j,ka),prnum(i,j,kb) - else - w_sec(i,j,k) = zero - endif - enddo - enddo - enddo - - do k=2,nzm - - km1 = k - 1 - do j=1,ny - do i=1,nx - -! Use backward difference in the vertical, use averaged values of "return-to-isotropy" -! time scale and diffusion coefficient - - wrk1 = one / adzi(i,j,k) ! adzi(k) = (zl(k)-zl(km1)) -! wrk3 = max(tkh(i,j,k),pt01) * wrk1 - wrk3 = max(tkh(i,j,k),epsln) * wrk1 - - sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 - -! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 -! No rain, snow or graupel in pdf (Annig, 08/29/2018) - - wrk1 = hl(i,j,k) - hl(i,j,km1) & - + (qpl(i,j,k) - qpl(i,j,km1)) * fac_cond & - + (qpi(i,j,k) - qpi(i,j,km1)) * fac_sub - wthl_sec(i,j,k) = - wrk3 * wrk1 - -! SGS vertical flux of total water. Eq 2 in BK13 - - wrk2 = total_water(i,j,k) - total_water(i,j,km1) - wqw_sec(i,j,k) = - wrk3 * wrk2 - -! Second moment of liquid/ice water static energy. Eq 4 in BK13 - - thl_sec(i,j,k) = thl2tune * sm * wrk1 * wrk1 - -! Second moment of total water mixing ratio. Eq 3 in BK13 - - qw_sec(i,j,k) = qw2tune * sm * wrk2 * wrk2 - -! Covariance of total water mixing ratio and liquid/ice water static energy. -! Eq 5 in BK13 - - qwthl_sec(i,j,k) = qwthl2tune * sm * wrk1 * wrk2 - - enddo ! i loop - enddo ! j loop - enddo ! k loop - -! These would be at the surface - do we need them? - do j=1,ny - do i=1,nx -! wthl_sec(i,j,1) = wthl_sec(i,j,2) -! wqw_sec(i,j,1) = wqw_sec(i,j,2) - thl_sec(i,j,1) = thl_sec(i,j,2) - qw_sec(i,j,1) = qw_sec(i,j,2) - qwthl_sec(i,j,1) = qwthl_sec(i,j,2) - enddo - enddo - -! Diagnose the third moment of SGS vertical velocity - - call canuto() - -! Recover parameters of the subgrid PDF using diagnosed moments -! and calculate SGS cloudiness, condensation and it's effects on temeperature -! and moisture variables - - call assumed_pdf() - -contains - - subroutine tke_shoc() - -! This subroutine solves the TKE equation, -! Heavily based on SAM's tke_full.f90 by Marat Khairoutdinov - - real grd,betdz,Cee,lstarn, lstarp, bbb, omn, omp,qsatt,dqsat, smix, & - buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss,a_prod_bu_debug, buoy_sgs_debug, & - tscale1, wrk, wrk1, wtke, wtk2, rdtn, tkef2 - integer i,j,k,ku,kd,itr,k1 - - rdtn = one / dtn - - call tke_shear_prod(def2) ! Calculate shear production of TKE - -! Ensure values of TKE are reasonable - - do k=1,nzm - do j=1,ny - do i=1,nx - tke(i,j,k) = max(min_tke,tke(i,j,k)) - tkesbdiss(i,j,k) = zero -! tkesbshear(i,j,k) = zero -! tkesbbuoy(i,j,k) = zero - enddo - enddo - enddo - - call eddy_length() ! Find turbulent mixing length - call check_eddy() ! Make sure it's reasonable - - tkef2 = 1.0 - tkef1 - do k=1,nzm - ku = k+1 - kd = k - -! Cek = Ce * cefac - - if(k == 1) then - ku = 2 - kd = 2 -! Cek = Ces - elseif(k == nzm) then - ku = k - kd = k -! Cek = Ces - endif - - if (dis_opt > 0) then - do j=1,ny - do i=1,nx - wrk = (zl(i,j,k)-zi(i,j,1)) / adzl(i,j,1) + 1.5 - cek(i,j) = 1.0 + 2.0 / max((wrk*wrk - 3.3), 0.5) - enddo - enddo - else - if (k == 1) then - cek = ces * cesfac - else - cek = ce * cefac - endif - endif - - do j=1,ny - do i=1,nx - grd = adzl(i,j,k) ! adzl(k) = zi(k+1)-zi(k) - - -! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in -! assumed_pdf(). The value used here is from the previous time step - - a_prod_bu = ggr / thv(i,j,k) * wthv_sec(i,j,k) - -! If wthv_sec from subgrid PDF is not available use Brunt-Vaisalla frequency from eddy_length() - -!Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux -!Presumably it is more precise than BV freq. calculated in eddy_length()? - - buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,j,ku)+tkh(i,j,kd) + 0.0001) ! tkh is eddy thermal diffussivity - - -!Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) - - if (buoy_sgs <= zero) then - smix = grd - else - smix = min(grd,max(0.1*grd, 0.76*sqrt(tke(i,j,k)/(buoy_sgs+1.e-10)))) - endif - - ratio = smix/grd - Cee = Cek(i,j) * (pt19 + pt51*ratio) * max(one, sqrt(pcrit/prsl(i,j,k))) - -! TKE shear production term - a_prod_sh = half*(def2(i,j,ku)*tkh(i,j,ku)*prnum(i,j,ku) & - + def2(i,j,kd)*tkh(i,j,kd)*prnum(i,j,kd)) - - -! smixt (turb. mixing lenght) is calculated in eddy_length() -! Explicitly integrate TKE equation forward in time -! a_diss = Cee/smixt(i,j,k)*tke(i,j,k)**1.5 ! TKE dissipation term -! tke(i,j,k) = max(zero,tke(i,j,k)+dtn*(max(zero,a_prod_sh+a_prod_bu)-a_diss)) - -! Semi-implicitly integrate TKE equation forward in time - - wtke = tke(i,j,k) - wtk2 = wtke -! wrk = (dtn*Cee)/smixt(i,j,k) - wrk = (dtn*Cee) / smixt(i,j,k) - wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wrk1=',wrk1,& -! ' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,' dtn=',dtn,' smixt=',& -! smixt(i,j,k),' tkh=',tkh(i,j,ku),tkh(i,j,kd),' def2=',def2(i,j,ku),def2(i,j,kd)& -! ,' prnum=',prnum(i,j,ku),prnum(i,j,kd),' wthv_sec=',wthv_sec(i,j,k),' thv=',thv(i,j,k) - - do itr=1,nitr ! iterate for implicit solution - wtke = min(max(min_tke, wtke), max_tke) - a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term - wtke = wrk1 / (one+a_diss) - wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& -! ' a_diss=',a_diss,' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,& -! ' wrk1=',wrk1,' itr=',itr,' k=',k - - wtk2 = wtke - - enddo - - tke(i,j,k) = min(max(min_tke, wtke), max_tke) - a_diss = wrk*sqrt(tke(i,j,k)) - - tscale1 = (dtn+dtn) / a_diss ! corrected Eq 8 in BK13 -- tau = 2*tke/eps - - tkesbdiss(i,j,k) = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon - - -! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 - - if (buoy_sgs <= zero) then - isotropy(i,j,k) = min(max_eddy_dissipation_time_scale,tscale1) - else - isotropy(i,j,k) = min(max_eddy_dissipation_time_scale, & - tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) - endif - -! TKE budget terms - -! tkesbdiss(i,j,k) = a_diss -! tkesbshear(i,j,k) = a_prod_sh -! tkesbbuoy(i,j,k) = a_prod_bu -! tkesbbuoy_debug(i,j,k) = a_prod_bu_debug -! tkebuoy_sgs(i,j,k) = buoy_sgs - - enddo ! i loop - enddo ! j loop - enddo ! k -! - wrk = half * ck - do k=2,nzm - k1 = k - 1 - do j=1,ny - do i=1,nx - tkh(i,j,k) = min(tkhmax, wrk * (isotropy(i,j,k) * tke(i,j,k) & - + isotropy(i,j,k1) * tke(i,j,k1))) ! Eddy thermal diffusivity - enddo ! i - enddo ! j - enddo ! k - - - end subroutine tke_shoc - - - subroutine tke_shear_prod(def2) - -! Calculate TKE shear production term - - real, intent(out) :: def2(nx,ny,nzm) - - real rdzw, wrku, wrkv, wrkw - integer i,j,k,k1 - -! Calculate TKE shear production term at layer interface - - do k=2,nzm - k1 = k - 1 - do j=1,ny - do i=1,nx - rdzw = one / adzi(i,j,k) - wrku = (u(i,j,k)-u(i,j,k1)) * rdzw - wrkv = (v(i,j,k)-v(i,j,k1)) * rdzw -! wrkw = (w(i,j,k)-w(i,j,k1)) * rdzw - def2(i,j,k) = wrku*wrku + wrkv*wrkv !+ 2*wrkw(1) * wrkw(1) - enddo - enddo - enddo ! k loop - do j=1,ny - do i=1,nx -! def2(i,j,1) = def2(i,j,2) - def2(i,j,1) = (u(i,j,1)*u(i,j,1) + v(i,j,1)*v(i,j,1)) & - / (zl(i,j,1)*zl(i,j,1)) - enddo - enddo - - end subroutine tke_shear_prod - - subroutine eddy_length() - -! This subroutine computes the turbulent length scale based on a new -! formulation described in BK13 - -! Local variables - real wrk, wrk1, wrk2, wrk3 - integer i, j, k, kk, kl, ku, kb, kc, kli, kui - - do j=1,ny - do i=1,nx - cldarr(i,j) = zero - numer(i,j) = zero - denom(i,j) = zero - enddo - enddo - -! Find the length scale outside of clouds, that includes boundary layers. - - do k=1,nzm - do j=1,ny - do i=1,nx - -! Reinitialize the mixing length related arrays to zero -! smixt(i,j,k) = one ! shoc_mod module variable smixt - smixt(i,j,k) = epsln ! shoc_mod module variable smixt - brunt(i,j,k) = zero - -!Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) -!Outside of cloud, integrate from the surface to the cloud base -!Should the 'if' below check if the cloud liquid < a small constant instead? - - if (qcl(i,j,k)+qci(i,j,k) <= zero) then - tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) - numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 - denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 - else - cldarr(i,j) = one ! Take note of columns containing cloud. - endif - enddo - enddo - enddo - -! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) - do j=1,ny - do i=1,nx - if (denom(i,j) > zero .and. numer(i,j) > zero) then - l_inf(i,j) = min(0.1 * (numer(i,j)/denom(i,j)), 100.0) - else - l_inf(i,j) = 100.0 - endif - enddo - enddo - -!Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) - do k=1,nzm - - kb = k-1 - kc = k+1 - if (k == 1) then - kb = 1 - kc = 2 - thedz(:,:) = adzi(:,:,kc) - elseif (k == nzm) then - kb = nzm-1 - kc = nzm - thedz(:,:) = adzi(:,:,k) - else - thedz(:,:) = adzi(:,:,kc) + adzi(:,:,k) ! = (z(k+1)-z(k-1)) - endif - - do j=1,ny - do i=1,nx - -! vars module variable bet (=ggr/tv0) ; grid module variable adzi - - betdz = bet(i,j,k) / thedz(i,j) - - tkes = sqrt(tke(i,j,k)) - -! Compute local Brunt-Vaisalla frequency - - wrk = qcl(i,j,k) + qci(i,j,k) - if (wrk > zero) then ! If in the cloud - -! Find the in-cloud Brunt-Vaisalla frequency - - omn = qcl(i,j,k) / (wrk+1.e-20) ! Ratio of liquid water to total water - -! Latent heat of phase transformation based on relative water phase content -! fac_cond = lcond/cp, fac_fus = lfus/cp - - lstarn = fac_cond + (one-omn)*fac_fus - -! Derivative of saturation mixing ratio over water/ice wrt temp. based on relative water phase content - dqsat = omn * dtqsatw(tabs(i,j,k),prsl(i,j,k)) & - + (one-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) - -! Saturation mixing ratio over water/ice wrt temp based on relative water phase content - - qsatt = omn * qsatw(tabs(i,j,k),prsl(i,j,k)) & - + (one-omn) * qsati(tabs(i,j,k),prsl(i,j,k)) - -! liquid/ice moist static energy static energy divided by cp? - - bbb = (one + epsv*qsatt-wrk-qpl(i,j,k)-qpi(i,j,k) & - + 1.61*tabs(i,j,k)*dqsat) / (one+lstarn*dqsat) - -! Calculate Brunt-Vaisalla frequency using centered differences in the vertical - - brunt(i,j,k) = betdz*(bbb*(hl(i,j,kc)-hl(i,j,kb)) & - + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,j,k)) & - * (total_water(i,j,kc)-total_water(i,j,kb)) & - + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) - - else ! outside of cloud - -! Find outside-of-cloud Brunt-Vaisalla frequency -! Only unsaturated air, rain and snow contribute to virt. pot. temp. -! liquid/ice moist static energy divided by cp? - - bbb = one + epsv*qv(i,j,k) - qpl(i,j,k) - qpi(i,j,k) - brunt(i,j,k) = betdz*( bbb*(hl(i,j,kc)-hl(i,j,kb)) & - + epsv*tabs(i,j,k)*(total_water(i,j,kc)-total_water(i,j,kb)) & - + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & - + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) - endif - -! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. -! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. - - if (brunt(i,j,k) >= zero) then - brunt2(i,j,k) = brunt(i,j,k) - else - brunt2(i,j,k) = zero - endif - -! Calculate turbulent length scale in the boundary layer. -! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) - -! Keep the length scale adequately small near the surface following Blackadar (1984) -! Note that this is not documented in BK13 and was added later for SP-CAM runs - -! if (k == 1) then -! term = 600.*tkes -! smixt(i,j,k) = term + (0.4*zl(i,j,k)-term)*exp(-zl(i,j,k)*0.01) -! else - -! tscale is the eddy turnover time scale in the boundary layer and is -! an empirically derived constant - - if (tkes > zero .and. l_inf(i,j) > zero) then - wrk1 = one / (tscale*tkes*vonk*zl(i,j,k)) - wrk2 = one / (tscale*tkes*l_inf(i,j)) - wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,j,k) / tke(i,j,k) - wrk1 = sqrt(one / max(wrk1,1.0e-8)) * (one/0.3) -! smixt(i,j,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) - smixt(i,j,k) = min(max_eddy_length_scale, wrk1) - -! smixt(i,j,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,j,k))) & -! + (1./(tscale*tkes*l_inf(i,j)))+0.01*(brunt2(i,j,k)/tke(i,j,k)))))/0.3) -! else -! smixt(i,j,k) = zero - endif - -! endif - - enddo - - enddo - enddo - - -! Now find the in-cloud turbulence length scale -! See Eq. 13 in BK13 (Eq. 4.18 in Pete's disseration) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! Remove after coupling to subgrid PDF. -!wthv_sec = -300/ggr*brunt*tk -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! determine cubed convective velocity scale (conv_vel2) inside the cloud - -! call conv_scale() ! inlining the relevant code - -! do j=1,ny -! do i=1,nx -! conv_vel2(i,j,1) = zero ! Convective velocity scale cubed -! enddo -! enddo - ! Integrate velocity scale in the vertical -! do k=2,nzm -! do j=1,ny -! do i=1,nx -! conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & -! + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) -! enddo -! enddo -! enddo - - do j=1,ny - do i=1,nx - - if (cldarr(i,j) == 1) then ! If there's a cloud in this column - - kl = 0 - ku = 0 - do k=2,nzm-3 - -! Look for the cloud base in this column -! thresh (=0) is a variable local to eddy_length(). Should be a module constant. - wrk = qcl(i,j,k) + qci(i,j,k) - if (wrk > thresh .and. kl == 0) then - kl = k - endif - -! Look for the cloud top in this column - if (wrk > thresh .and. qcl(i,j,k+1)+qci(i,j,k+1) <= thresh) then - ku = k -! conv_vel2 (Cubed convective velocity scale) is calculated in conv_scale() -! Use the value of conv_vel2 at the top of the cloud. -! conv_var = conv_vel2(i,j,k)**(oneb3) - endif - -! Compute the mixing length scale for the cloud layer that we just found -! if (kl > 0 .and. ku > 0 .and. ku-kl > 1) then - if (kl > 0 .and. ku > 0 .and. ku-kl > 0) then - -! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud - conv_var = zero - do kk=kl,ku - conv_var = conv_var+ 2.5*adzi(i,j,kk)*bet(i,j,kk)*wthv_sec(i,j,kk) - enddo - conv_var = conv_var ** oneb3 - - if (conv_var > 0) then ! If convective vertical velocity scale > 0 - - depth = (zl(i,j,ku)-zl(i,j,kl)) + adzl(i,j,kl) - - - do kk=kl,ku -! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) - -! wrk = conv_var/(depth*sqrt(tke(i,j,kk))) -! wrk = wrk * wrk + pt01*brunt2(i,j,kk)/tke(i,j,kk) - - wrk = conv_var/(depth*depth*sqrt(tke(i,j,kk))) & - + pt01*brunt2(i,j,kk)/tke(i,j,kk) - - smixt(i,j,kk) = min(max_eddy_length_scale, (one/0.3)*sqrt(one/wrk)) - - enddo - - endif ! If convective vertical velocity scale > 0 - kl = zero - ku = zero - endif ! if inside the cloud layer - - enddo ! k=2,nzm-3 - endif ! if in the cloudy column - enddo ! i=1,nx - enddo ! j=1,ny - - - end subroutine eddy_length - - - subroutine conv_scale() - -! This subroutine calculates the cubed convective velocity scale needed -! for the definition of the length scale in clouds -! See Eq. 16 in BK13 (Eq. 4.21 in Pete's dissertation) - - integer i, j, k - -!!!!!!!!! -!! A bug in formulation of conv_vel -! Obtain it by averaging conv_vel2 in the horizontal -!!!!!!!!!! - -! conv_vel(1)=zero ! Horizontally averaged convective velocity scale cubed - do j=1,ny - do i=1,nx - conv_vel2(i,j,1) = zero ! Convective velocity scale cubed - enddo - enddo -! Integrate velocity scale in the vertical - do k=2,nzm -! conv_vel(k)=conv_vel(k-1) - do j=1,ny - do i=1,nx -!********************************************************************** -!Do not include grid-scale contribution to convective velocity scale in GCM applications -! conv_vel(k)=conv_vel(k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+tvws(k)) -! conv_vel(k)=conv_vel(k)+2.5*adzi(i,j,k)*bet(i,j,k)*(tvws(k)) -!Do not include grid-scale contribution to convective velocity scale in GCM applications -! conv_vel2(i,j,k)=conv_vel2(i,j,k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+wthv_sec(i,j,k)) -!********************************************************************** - - conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & - + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) - enddo - enddo - enddo - - end subroutine conv_scale - - - subroutine check_eddy() - -! This subroutine checks eddy length values - - integer i, j, k, kb, ks, zend - real wrk -! real zstart, zthresh, qthresh - -! Temporary kludge for marine stratocumulus under very strong inversions at coarse resolution -! Placement until some explicity PBL top is put in -! Not used. -! zthresh = 100. -! qthresh = -6.0 - - do k=1,nzm - - if (k == nzm) then - kb = k - else - kb = k+1 - endif - - do j=1,ny - do i=1,nx - - wrk = 0.1*adzl(i,j,k) - ! Minimum 0.1 of local dz - smixt(i,j,k) = max(wrk, min(max_eddy_length_scale,smixt(i,j,k))) - -! If chracteristic grid dimension in the horizontal< 1000m, set lengthscale to -! be not larger that that. -! if (sqrt(dx*dy) .le. 1000.) smixt(i,j,k)=min(sqrt(dx*dy),smixt(i,j,k)) - - if (qcl(i,j,kb) == 0 .and. qcl(i,j,k) > 0 .and. brunt(i,j,k) > 1.e-4) then -!If just above the cloud top and atmosphere is stable, set to 0.1 of local dz - smixt(i,j,k) = wrk - endif - - enddo ! i - enddo ! j - enddo ! k - - end subroutine check_eddy - - subroutine canuto() - -! Subroutine impements an analytic expression for the third moment of SGS vertical velocity -! based on Canuto et at, 2001, JAS, 58, 1169-1172 (further referred to as C01) -! This allows to avoid having a prognostic equation for the third moment. -! Result is returned in a global variable w3 defined at the interface levels. - -! Local variables - integer i, j, k, kb, kc - - real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & - omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & - wrk, wrk1, wrk2, wrk3, avew -! cond, wrk, wrk1, wrk2, wrk3, avew -! -! See Eq. 7 in C01 (B.7 in Pete's dissertation) - real, parameter :: c=7.0, a0=0.52/(c*c*(c-2.)), a1=0.87/(c*c), & - a2=0.5/c, a3=0.6/(c*(c-2.)), a4=2.4/(3.*c+5.), & - a5=0.6/(c*(3.*c+5)) -!Moorthi a5=0.6/(c*(3.+5.*c)) - -! do k=1,nzm - do k=2,nzm - - kb = k-1 - kc = k+1 - -! if(k == 1) then -! kb = 1 -! kc = 2 -! do j=1,ny -! do i=1,nx -! thedz(i,j) = one / adzl(i,j,kc) -! thedz2(i,j) = thedz(i,j) -! enddo -! enddo -! elseif(k == nzm) then - if (k == nzm) then - kb = nzm-1 - kc = nzm - do j=1,ny - do i=1,nx - thedz(i,j) = one / adzi(i,j,k) - thedz2(i,j) = one / adzl(i,j,kb) - enddo - enddo - else - do j=1,ny - do i=1,nx - thedz(i,j) = one / adzi(i,j,k) - thedz2(i,j) = one / (adzl(i,j,k)+adzl(i,j,kb)) - enddo - enddo - endif - - - do j=1,ny - do i=1,nx - - iso = half*(isotropy(i,j,k)+isotropy(i,j,kb)) - isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared - buoy_sgs2 = isosqr*half*(brunt(i,j,k)+brunt(i,j,kb)) - bet2 = half*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared - - -! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) - - - avew = half*(w_sec(i,j,k)+w_sec(i,j,kb)) -!aab -! - wrk1 = bet2*iso - wrk2 = thedz2(i,j)*wrk1*wrk1*iso - wrk3 = thl_sec(i,j,kc) - thl_sec(i,j,kb) - - f0 = wrk2 * wrk1 * wthl_sec(i,j,k) * wrk3 - - wrk = wthl_sec(i,j,kc) - wthl_sec(i,j,kb) - - f1 = wrk2 * (wrk*wthl_sec(i,j,k) + half*avew*wrk3) - - wrk1 = bet2*isosqr - f2 = thedz(i,j)*wrk1*wthl_sec(i,j,k)*(w_sec(i,j,k)-w_sec(i,j,kb)) & - + (thedz2(i,j)+thedz2(i,j))*bet(i,j,k)*isosqr*wrk - - f3 = thedz2(i,j)*wrk1*wrk + thedz(i,j)*bet2*isosqr*(wthl_sec(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) - - wrk1 = thedz(i,j)*iso*avew - f4 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) - - f5 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb)) - - -! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) - - omega0 = a4 / (one-a5*buoy_sgs2) - omega1 = omega0 / (c+c) - omega2 = omega1*f3+(5./4.)*omega0*f4 - -! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) - - wrk1 = one / (one-(a1+a3)*buoy_sgs2) - wrk2 = one / (one-a3*buoy_sgs2) - X0 = wrk1 * (a2*buoy_sgs2*(one-a3*buoy_sgs2)) - Y0 = wrk2 * (two*a2*buoy_sgs2*X0) - X1 = wrk1 * (a0*f0+a1*f1+a2*(one-a3*buoy_sgs2)*f2) - Y1 = wrk2 * (two*a2*(buoy_sgs2*X1+(a0/a1)*f0+f1)) - -! Compute the A0, A1 terms, see Eq. 5d in C01 (B.5 in Pete's dissertation) - - AA0 = omega0*X0 + omega1*Y0 - AA1 = omega0*X1 + omega1*Y1 + omega2 - -! Finally, we have the third moment of w, see Eq. 4c in C01 (B.4 in Pete's dissertation) -! cond is an estimate of third moment from second oment - If the third moment is larger -! than the estimate - limit w3. - -!aab - -! Implemetation of the C01 approach in this subroutine is nearly complete -! (the missing part are Eqs. 5c and 5e which are very simple) -! therefore it's easy to diagnose other third order moments obtained in C01 using this code. - - enddo - enddo - enddo - do j=1,ny - do i=1,nx - w3(i,j,1) = w3(i,j,2) - enddo - enddo - - end subroutine canuto - - subroutine assumed_pdf() - -! Compute SGS buoyancy flux, SGS cloud fraction, and SGS condensation -! using assumed analytic double-gaussian PDF for SGS vertical velocity, -! moisture, and liquid/ice water static energy, based on the -! general approach of Larson et al 2002, JAS, 59, 3519-3539, -! and Golaz et al 2002, JAS, 59, 3540-3551 -! References in the comments in this code are given to -! the Appendix A of Pete Bogenschutz's dissertation. - -! Local variables - - integer i,j,k,ku,kd - real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2, cond_w - -! bastoeps = basetemp / epsterm - - -! Initialize for statistics - do k=1,nzm - wqlsb(k) = zero - wqisb(k) = zero - enddo - - DO k=1,nzm - - kd = k - ku = k + 1 -! if (k == nzm) ku = k - - DO j=1,ny - DO i=1,nx - -! Initialize cloud variables to zero - diag_qn = zero - diag_frac = zero - diag_ql = zero - diag_qi = zero - - pval = prsl(i,j,k) - pfac = pval * 1.0e-5 - pkap = pfac ** kapa - -! Read in liquid/ice static energy, total water mixing ratio, -! and vertical velocity to variables PDF needs - - thl_first = hl(i,j,k) + fac_cond*qpl(i,j,k) & - + fac_sub*qpi(i,j,k) - - qw_first = total_water(i,j,k) -! w_first = half*(w(i,j,kd)+w(i,j,ku)) - w_first = w(i,j,k) - - -! GET ALL INPUT VARIABLES ON THE SAME GRID -! Points to be computed with relation to thermo point -! Read in points that need to be averaged - - if (k < nzm) then - w3var = half*(w3(i,j,kd)+w3(i,j,ku)) - thlsec = max(zero, half*(thl_sec(i,j,kd)+thl_sec(i,j,ku)) ) - qwsec = max(zero, half*(qw_sec(i,j,kd)+qw_sec(i,j,ku)) ) - qwthlsec = half * (qwthl_sec(i,j,kd) + qwthl_sec(i,j,ku)) - wqwsec = half * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) - wthlsec = half * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) - else ! at the model top assuming zeros - w3var = half*w3(i,j,k) - thlsec = max(zero, half*thl_sec(i,j,k)) - qwsec = max(zero, half*qw_sec(i,j,k)) - qwthlsec = half * qwthl_sec(i,j,k) - wqwsec = half * wqw_sec(i,j,k) - wthlsec = half * wthl_sec(i,j,k) - endif - -! w3var = w3(i,j,k) -! thlsec = max(zero,thl_sec(i,j,k)) -! qwsec = max(zero,qw_sec(i,j,k)) -! qwthlsec = qwthl_sec(i,j,k) -! wqwsec = wqw_sec(i,j,k) -! wthlsec = wthl_sec(i,j,k) - -! Compute square roots of some variables so we don't have to do it again -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' w_sec=',w_sec(i,j,k),' k=',k - if (w_sec(i,j,k) > zero) then - sqrtw2 = sqrt(w_sec(i,j,k)) - else - sqrtw2 = zero - endif - if (thlsec > zero) then - sqrtthl = sqrt(thlsec) - else - sqrtthl = zero - endif - if (qwsec > zero) then - sqrtqt = sqrt(qwsec) - else - sqrtqt = zero - endif - - -! Find parameters of the double Gaussian PDF of vertical velocity - -! Skewness of vertical velocity -! Skew_w = w3var / w_sec(i,j,k)**(3./2.) -! Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi - - IF (w_sec(i,j,k) <= w_tol_sqd) THEN ! If variance of w is too small then - ! PDF is a sum of two delta functions - Skew_w = zero - w1_1 = w_first - w1_2 = w_first - w2_1 = zero - w2_2 = zero - aterm = half - onema = half - ELSE - -!aab - - Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi -! Proportionality coefficients between widths of each vertical velocity -! gaussian and the sqrt of the second moment of w - w2_1 = 0.4 - w2_2 = 0.4 - -! Compute realtive weight of the first PDF "plume" -! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 - - wrk = one - w2_1 - aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) - onema = one - aterm - - sqrtw2t = sqrt(wrk) - -! Eq. A.5-A.6 - wrk = sqrt(onema/aterm) - w1_1 = sqrtw2t * wrk - w1_2 = - sqrtw2t / wrk - - w2_1 = w2_1 * w_sec(i,j,k) - w2_2 = w2_2 * w_sec(i,j,k) - - ENDIF - -! Find parameters of the PDF of liquid/ice static energy - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thlsec=',thlsec,' w1_2=',w1_2,' w1_1=',w1_1,& -! ' thl_first=',thl_first,' k=',k,' wthlsec=',wthlsec,sqrtw2,sqrtthl - IF (thlsec <= thl_tol*thl_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN - thl1_1 = thl_first - thl1_2 = thl_first - thl2_1 = zero - thl2_2 = zero - sqrtthl2_1 = zero - sqrtthl2_2 = zero - ELSE - - corrtest1 = max(-one,min(one,wthlsec/(sqrtw2*sqrtthl))) - - thl1_1 = -corrtest1 / w1_2 ! A.7 - thl1_2 = -corrtest1 / w1_1 ! A.8 - - wrk1 = thl1_1 * thl1_1 - wrk2 = thl1_2 * thl1_2 - wrk3 = three * (one - aterm*wrk1 - onema*wrk2) - wrk4 = -skew_facw*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi -! wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi -! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 - wrk = three * (thl1_2-thl1_1) - if (wrk /= zero) then - thl2_1 = thlsec * min(100.,max(zero,( thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - thl2_2 = thlsec * min(100.,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 - else - thl2_1 = zero - thl2_2 = zero - endif -! -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' sqrtthl=',sqrtthl,' thl_first=',thl_first,& -! ' thl1_2=',thl1_2,' corrtest1=',corrtest1,' w1_2=',w1_2,' w1_1=',w1_1 - - thl1_1 = thl1_1*sqrtthl + thl_first - thl1_2 = thl1_2*sqrtthl + thl_first - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' thl1_2=',thl1_2 - - sqrtthl2_1 = sqrt(thl2_1) - sqrtthl2_2 = sqrt(thl2_2) - - ENDIF - -! FIND PARAMETERS FOR TOTAL WATER MIXING RATIO - - IF (qwsec <= rt_tol*rt_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN - qw1_1 = qw_first - qw1_2 = qw_first - qw2_1 = zero - qw2_2 = zero - sqrtqw2_1 = zero - sqrtqw2_2 = zero - ELSE - - corrtest2 = max(-one,min(one,wqwsec/(sqrtw2*sqrtqt))) - - qw1_1 = - corrtest2 / w1_2 ! A.7 - qw1_2 = - corrtest2 / w1_1 ! A.8 - - tsign = abs(qw1_2-qw1_1) - -! Skew_qw = skew_facw*Skew_w - - IF (tsign > 0.4) THEN - Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2) THEN - Skew_qw = zero - ELSE - Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) - ENDIF - - wrk1 = qw1_1 * qw1_1 - wrk2 = qw1_2 * qw1_2 - wrk3 = three * (one - aterm*wrk1 - onema*wrk2) - wrk4 = Skew_qw - aterm*wrk1*qw1_1 - onema*wrk2*qw1_2 - wrk = three * (qw1_2-qw1_1) - - if (wrk /= zero) then - qw2_1 = qwsec * min(100.,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - qw2_2 = qwsec * min(100.,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 - else - qw2_1 = zero - qw2_2 = zero - endif -! - qw1_1 = qw1_1*sqrtqt + qw_first - qw1_2 = qw1_2*sqrtqt + qw_first - - sqrtqw2_1 = sqrt(qw2_1) - sqrtqw2_2 = sqrt(qw2_2) - - ENDIF - -! CONVERT FROM TILDA VARIABLES TO "REAL" VARIABLES - - w1_1 = w1_1*sqrtw2 + w_first - w1_2 = w1_2*sqrtw2 + w_first - -! FIND WITHIN-PLUME CORRELATIONS - - testvar = aterm*sqrtqw2_1*sqrtthl2_1 + onema*sqrtqw2_2*sqrtthl2_2 - - IF (testvar == 0) THEN - r_qwthl_1 = zero - ELSE - r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first) & - -onema*(qw1_2-qw_first)*(thl1_2-thl_first))/testvar)) ! A.12 - ENDIF - -! BEGIN TO COMPUTE CLOUD PROPERTY STATISTICS - -! wrk1 = gamaz(i,j,k) - fac_cond * qpl(i,j,k) - fac_sub * qpi(i,j,k) -! Tl1_1 = thl1_1 - wrk1 -! Tl1_2 = thl1_2 - wrk1 - - Tl1_1 = thl1_1 - gamaz(i,j,k) - Tl1_2 = thl1_2 - gamaz(i,j,k) - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' Tl1_1=',Tl1_1,' Tl1_2=',Tl1_2,& -! ' wrk1=',wrk1,' thl1_1=',thl1_1,' thl1_2=',thl1_2,' qpl=',qpl(i,j,k),' qpi=',qpi(i,j,k) - -! Now compute qs - - esval1_1 = zero - esval2_1 = zero - eps_ss1 = eps - eps_ss2 = eps - om1 = one - -! Partition based on temperature for the first plume - - IF (Tl1_1 >= tbgmax) THEN - esval1_1 = min(fpvsl(Tl1_1), pval) -! esval1_1 = esatw(Tl1_1) - lstarn1 = lcond - ELSE IF (Tl1_1 <= tbgmin) THEN - esval1_1 = min(fpvsi(Tl1_1), pval) -! esval1_1 = esati(Tl1_1) - lstarn1 = lsub - eps_ss1 = eps * supice - ELSE - esval1_1 = min(fpvsl(Tl1_1), pval) - esval2_1 = min(fpvsi(Tl1_1), pval) -! esval1_1 = esatw(Tl1_1) -! esval2_1 = esati(Tl1_1) - om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) - lstarn1 = lcond + (one-om1)*lfus - eps_ss2 = eps * supice - - ENDIF - qs1 = om1 * eps_ss1*esval1_1/(pval-0.378*esval1_1) & - + (one-om1) * eps_ss2*esval2_1/(pval-0.378*esval2_1) - -! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) - beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 - - -! Are the two plumes equal? If so then set qs and beta -! in each column to each other to save computation - IF (Tl1_1 == Tl1_2) THEN - qs2 = qs1 - beta2 = beta1 - ELSE - - esval1_2 = zero - esval2_2 = zero - eps_ss1 = eps - eps_ss2 = eps - om2 = one - - IF (Tl1_2 >= tbgmax) THEN - esval1_2 = min(fpvsl(Tl1_2), pval) -! esval1_2 = esatw(Tl1_2) - lstarn2 = lcond - ELSE IF (Tl1_2 <= tbgmin) THEN - esval1_2 = min(fpvsi(Tl1_2), pval) -! esval1_2 = esati(Tl1_2) - lstarn2 = lsub - eps_ss1 = eps * supice - ELSE - esval1_2 = min(fpvsl(Tl1_2), pval) - esval2_2 = min(fpvsi(Tl1_2), pval) -! esval1_2 = esatw(Tl1_2) -! esval2_2 = esati(Tl1_2) - om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) - lstarn2 = lcond + (one-om2)*lfus - eps_ss2 = eps * supice - ENDIF - - qs2 = om2 * eps_ss1*esval1_2/(pval-0.378*esval1_2) & - + (one-om2) * eps_ss2*esval2_2/(pval-0.378*esval2_2) - -! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 - beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 - - ENDIF - - qs1 = qs1 * rhc(i,j,k) - qs2 = qs2 * rhc(i,j,k) - -! Now compute cloud stuff - compute s term - - cqt1 = one / (one+beta1*qs1) ! A.19 - wrk = qs1 * (one+beta1*qw1_1) * cqt1 - s1 = qw1_1 - wrk ! A.17 - cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 - - wrk1 = cthl1 * cthl1 - wrk2 = cqt1 * cqt1 -! std_s1 = sqrt(max(zero,wrk1*thl2_1+wrk2*qw2_1-2.*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) - std_s1 = sqrt(max(zero, wrk1*thl2_1+wrk2*qw2_1 & - - two*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) - - qn1 = zero - C1 = zero - - IF (std_s1 > zero) THEN - wrk = s1 / (std_s1*sqrt2) - C1 = max(zero, min(one, half*(one+erf(wrk)))) ! A.15 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& -! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k - -! IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 - qn1 = max(zero, s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk)) ! A.16 - ELSEIF (s1 > zero) THEN - C1 = one - qn1 = s1 - ENDIF - -! now compute non-precipitating cloud condensate - -! If two plumes exactly equal, then just set many of these -! variables to themselves to save on computation. - IF (qw1_1 == qw1_2 .and. thl2_1 == thl2_2 .and. qs1 == qs2) THEN - s2 = s1 - cthl2 = cthl1 - cqt2 = cqt1 - std_s2 = std_s1 - C2 = C1 - qn2 = qn1 - ELSE - - cqt2 = one / (one+beta2*qs2) - wrk = qs2 * (one+beta2*qw1_2) * cqt2 - s2 = qw1_2 - wrk - cthl2 = wrk*cqt2*cpolv*beta2*pkap - wrk1 = cthl2 * cthl2 - wrk2 = cqt2 * cqt2 -! std_s2 = sqrt(max(zero,wrk1*thl2_2+wrk2*qw2_2-2.*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) - std_s2 = sqrt(max(zero, wrk1*thl2_2+wrk2*qw2_2 & - - two*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) - - qn2 = zero - C2 = zero - - IF (std_s2 > zero) THEN - wrk = s2 / (std_s2*sqrt2) - C2 = max(zero, min(one, half*(one+erf(wrk)))) -! IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) - qn2 = max(zero, s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk)) - ELSEIF (s2 > zero) THEN - C2 = one - qn2 = s2 - ENDIF - - ENDIF - -! finally, compute the SGS cloud fraction - diag_frac = aterm*C1 + onema*C2 - - om1 = max(zero, min(one, (Tl1_1-tbgmin)*a_bg)) - om2 = max(zero, min(one, (Tl1_2-tbgmin)*a_bg)) - - qn1 = min(qn1,qw1_1) - qn2 = min(qn2,qw1_2) - - ql1 = qn1*om1 - ql2 = qn2*om2 - - qi1 = qn1 - ql1 - qi2 = qn2 - ql2 - -! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& -! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k,' tl1=',tl1_1,tl1_2,' om1=',om1,'om2=',om2& -! ,' tbgmin=',tbgmin,'a_bg=',a_bg - - - diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,j,k)) - diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) - diag_qi = diag_qn - diag_ql - - -! Update temperature variable based on diagnosed cloud properties - om1 = max(zero, min(one, (tabs(i,j,k)-tbgmin)*a_bg)) - lstarn1 = lcond + (one-om1)*lfus - tabs(i,j,k) = hl(i,j,k) - gamaz(i,j,k) + fac_cond*(diag_ql+qpl(i,j,k)) & - + fac_sub *(diag_qi+qpi(i,j,k)) & - + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating - -! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,1,k),' k=',k& -! ,' hl=',hl(i,j,k),' gamaz=',gamaz(i,j,k),' diag_ql=',diag_ql,' qpl=',qpl(i,j,k)& -! ,' diag_qi=',diag_qi,' qpi=',qpi(i,j,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& -! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 -! Update moisture fields - -! Update ncpl and ncpi Anning Cheng 03/11/2016 -! ncpl(i,j,k) = diag_ql/max(qc(i,j,k),1.e-10)*ncpl(i,j,k) -! The following commneted by Moorthi on April 26, 2017 to test blowing up -! ncpl(i,j,k) = (1.0-diag_ql/max(qc(i,j,k),1.e-10)) * ncpl(i,j,k) -! ncpi(i,j,k) = (1.0-diag_qi/max(qi(i,j,k),1.e-10)) * ncpi(i,j,k) - qc(i,j,k) = diag_ql - qi(i,j,k) = diag_qi - qwv(i,j,k) = total_water(i,j,k) - diag_qn - cld_sgs(i,j,k) = diag_frac - - -! Compute the liquid water flux - wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) - wqis = aterm * ((w1_1-w_first)*qi1) + onema * ((w1_2-w_first)*qi2) - -! Compute statistics for the fluxes so we don't have to save these variables - wqlsb(k) = wqlsb(k) + wqls - wqisb(k) = wqisb(k) + wqis - -! diagnostic buoyancy flux. Includes effects from liquid water, ice -! condensate, liquid & ice precipitation -! wrk = epsv * basetemp - wrk = epsv * thv(i,j,k) - - bastoeps = onebeps * thv(i,j,k) - - if (k < nzm) then - wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & - + (fac_cond-bastoeps)*wqls & - + (fac_sub-bastoeps) *wqis & - + ((lstarn1/cp)-thv(i,j,k))*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) - else - wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & - + (fac_cond-bastoeps)*wqls & - + (fac_sub-bastoeps) *wqis & - + ((lstarn1/cp)-thv(i,j,k))*half*wqp_sec(i,j,k) - endif - -! wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & -! + (fac_cond-bastoeps)*wqls & -! + (fac_sub-bastoeps)*wqis & -! + ((lstarn1/cp)-basetemp)*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) - - ENDDO - ENDDO - ENDDO - - - end subroutine assumed_pdf - - -! Saturation vapor pressure and mixing ratio subroutines -! Based on Flatau et al (1992), J. App. Met., 31, 1507-1513 -! Code by Marat Khairoutdinov - - - real function esatw(t) - real t ! temperature (K) - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & - 6.11239921, 0.443987641, 0.142986287e-1, & - 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & - 0.640689451e-10, -0.952447341e-13,-0.976195544e-15/ - real dt - dt = max(-80.,t-273.16) - esatw = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - end function esatw - - real function qsatw(t,p) -! implicit none - real t ! temperature (K) - real p ! pressure (Pa) - real esat -! esat = fpvs(t) - esat = fpvsl(t) - qsatw = 0.622 * esat/max(esat,p-0.378*esat) -! esat = esatw(t) -! qsatw = 0.622 * esat/max(esat,p-esat) - end function qsatw - - - real function esati(t) - real t ! temperature (K) - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & - 6.11147274, 0.503160820, 0.188439774e-1, & - 0.420895665e-3, 0.615021634e-5, 0.602588177e-7, & - 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ - real dt -! real esatw - if(t > 273.15) then - esati = esatw(t) - else if(t.gt.185.) then - dt = t-273.16 - esati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - else ! use some additional interpolation below 184K - dt = max(-100.,t-273.16) - esati = 0.00763685 + dt*(0.000151069+dt*7.48215e-07) - endif - end function esati - - real function qsati(t,p) - real t ! temperature (K) - real p ! pressure (Pa) - real esat !,esati -! esat = fpvs(t) - esat = fpvsi(t) - qsati = 0.622 * esat/max(esat,p-0.378*esat) -! esat = esati(t) -! qsati = 0.622 * esat/max(esat,p-esat) - end function qsati - - real function dtesatw(t) - real t ! temperature (K) - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & - 0.443956472, 0.285976452e-1, 0.794747212e-3, & - 0.121167162e-4, 0.103167413e-6, 0.385208005e-9, & - -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/ - real dt - dt = max(-80.,t-273.16) - dtesatw = a0 + dt* (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - end function dtesatw - - real function dtqsatw(t,p) - real t ! temperature (K) - real p ! pressure (Pa) -! real dtesatw - dtqsatw = 100.0*0.622*dtesatw(t)/p - end function dtqsatw - - real function dtesati(t) - real t ! temperature (K) - real a0,a1,a2,a3,a4,a5,a6,a7,a8 - data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & - 0.503223089, 0.377174432e-1, 0.126710138e-2, & - 0.249065913e-4, 0.312668753e-6, 0.255653718e-8, & - 0.132073448e-10, 0.390204672e-13, 0.497275778e-16/ - real dt -! real dtesatw - if(t > 273.15) then - dtesati = dtesatw(t) - else if(t > 185.) then - dt = t-273.16 - dtesati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) - else ! use additional interpolation below 185K - dt = max(-100.,t-273.16) - dtesati = 0.0013186 + dt*(2.60269e-05+dt*1.28676e-07) - endif - end function dtesati - - - real function dtqsati(t,p) - real t ! temperature (K) - real p ! pressure (Pa) -! real dtesati - dtqsati = 100.0*0.622*dtesati(t)/p - end function dtqsati - -end subroutine shoc_work - -end module shoc diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 deleted file mode 100644 index 4fc1bfa04..000000000 --- a/physics/gcycle.F90 +++ /dev/null @@ -1,245 +0,0 @@ -!>\file gcycle.F90 -!! This file repopulates specific time-varying sfc properties for -!! AMIP/forecast runs - -# 1 "physics/gcycle.F90" -!>\ingroup Noah_LSM -!! This subroutine repopulates specific time-varying sfc properties for -!! AMIP/forecast runs. - SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) -! -! - USE MACHINE, only: kind_phys - USE PHYSCONS, only: PI => con_PI - USE GFS_typedefs, only: GFS_control_type, GFS_grid_type, & - GFS_sfcprop_type, GFS_cldprop_type - implicit none - - integer, intent(in) :: nblks - type(GFS_control_type), intent(in) :: Model - type(GFS_grid_type), intent(in) :: Grid(nblks) - type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) - type(GFS_cldprop_type), intent(inout) :: Cldprop(nblks) - -! -! Local variables -! --------------- - integer :: & - I_INDEX(Model%nx*Model%ny), & - J_INDEX(Model%nx*Model%ny) - - real(kind=kind_phys) :: & - RLA (Model%nx*Model%ny), & - RLO (Model%nx*Model%ny), & - SLMASK (Model%nx*Model%ny), & - OROG (Model%nx*Model%ny), & - OROG_UF (Model%nx*Model%ny), & - SLIFCS (Model%nx*Model%ny), & - TSFFCS (Model%nx*Model%ny), & - SNOFCS (Model%nx*Model%ny), & - ZORFCS (Model%nx*Model%ny), & - TG3FCS (Model%nx*Model%ny), & - CNPFCS (Model%nx*Model%ny), & - AISFCS (Model%nx*Model%ny), & -! F10MFCS(Model%nx*Model%ny), & - VEGFCS (Model%nx*Model%ny), & - VETFCS (Model%nx*Model%ny), & - SOTFCS (Model%nx*Model%ny), & - CVFCS (Model%nx*Model%ny), & - CVBFCS (Model%nx*Model%ny), & - CVTFCS (Model%nx*Model%ny), & - SWDFCS (Model%nx*Model%ny), & - SIHFCS (Model%nx*Model%ny), & - SICFCS (Model%nx*Model%ny), & - SITFCS (Model%nx*Model%ny), & - VMNFCS (Model%nx*Model%ny), & - VMXFCS (Model%nx*Model%ny), & - SLPFCS (Model%nx*Model%ny), & - ABSFCS (Model%nx*Model%ny), & - ALFFC1 (Model%nx*Model%ny*2), & - ALBFC1 (Model%nx*Model%ny*4), & - SMCFC1 (Model%nx*Model%ny*Model%lsoil), & - STCFC1 (Model%nx*Model%ny*Model%lsoil), & - SLCFC1 (Model%nx*Model%ny*Model%lsoil) - - character(len=6) :: tile_num_ch - real(kind=kind_phys), parameter :: pifac=180.0/pi - real(kind=kind_phys) :: sig1t - integer :: npts, len, nb, ix, jx, ls, ios - logical :: exists -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' -! *,lonsinpe(0,1) - - tile_num_ch = " " - if (Model%tile_num < 10) then - write(tile_num_ch, "(a4,i1)") "tile", Model%tile_num - else - write(tile_num_ch, "(a4,i2)") "tile", Model%tile_num - endif - - len = 0 - do jx = Model%jsc, (Model%jsc+Model%ny-1) - do ix = Model%isc, (Model%isc+Model%nx-1) - len = len + 1 - i_index(len) = ix - j_index(len) = jx - enddo - enddo - - sig1t = 0.0 - npts = Model%nx*Model%ny -! - len = 0 - do nb = 1,nblks - do ix = 1,size(Grid(nb)%xlat,1) - len = len + 1 - RLA (len) = Grid(nb)%xlat (ix) * pifac - RLO (len) = Grid(nb)%xlon (ix) * pifac - OROG (len) = Sfcprop(nb)%oro (ix) - OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) - SLIFCS (len) = Sfcprop(nb)%slmsk (ix) - if ( Model%nstf_name(1) > 0 ) then - TSFFCS(len) = Sfcprop(nb)%tref (ix) - else - TSFFCS(len) = Sfcprop(nb)%tsfc (ix) - endif - SNOFCS (len) = Sfcprop(nb)%weasd (ix) - ZORFCS (len) = Sfcprop(nb)%zorl (ix) - TG3FCS (len) = Sfcprop(nb)%tg3 (ix) - CNPFCS (len) = Sfcprop(nb)%canopy (ix) -! F10MFCS (len) = Sfcprop(nb)%f10m (ix) - VEGFCS (len) = Sfcprop(nb)%vfrac (ix) - VETFCS (len) = Sfcprop(nb)%vtype (ix) - SOTFCS (len) = Sfcprop(nb)%stype (ix) - CVFCS (len) = Cldprop(nb)%cv (ix) - CVBFCS (len) = Cldprop(nb)%cvb (ix) - CVTFCS (len) = Cldprop(nb)%cvt (ix) - SWDFCS (len) = Sfcprop(nb)%snowd (ix) - SIHFCS (len) = Sfcprop(nb)%hice (ix) - SICFCS (len) = Sfcprop(nb)%fice (ix) - SITFCS (len) = Sfcprop(nb)%tisfc (ix) - VMNFCS (len) = Sfcprop(nb)%shdmin (ix) - VMXFCS (len) = Sfcprop(nb)%shdmax (ix) - SLPFCS (len) = Sfcprop(nb)%slope (ix) - ABSFCS (len) = Sfcprop(nb)%snoalb (ix) - - ALFFC1 (len ) = Sfcprop(nb)%facsf (ix) - ALFFC1 (len + npts) = Sfcprop(nb)%facwf (ix) - - ALBFC1 (len ) = Sfcprop(nb)%alvsf (ix) - ALBFC1 (len + npts ) = Sfcprop(nb)%alvwf (ix) - ALBFC1 (len + npts*2) = Sfcprop(nb)%alnsf (ix) - ALBFC1 (len + npts*3) = Sfcprop(nb)%alnwf (ix) - - do ls = 1,Model%lsoil - SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) - STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) - SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) - enddo - - IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN - SLMASK(len) = 0 - ELSE - SLMASK(len) = 1 - ENDIF - - IF (SLIFCS(len) .EQ. 2) THEN - AISFCS(len) = 1. - ELSE - AISFCS(len) = 0. - ENDIF - -! if (Model%me .eq. 0) -! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) - ENDDO !-----END BLOCK SIZE LOOP------------------------------ - ENDDO !-----END BLOCK LOOP------------------------------- - -! check -! call mymaxmin(slifcs,len,len,1,'slifcs') -! call mymaxmin(slmask,len,len,1,'slmsk') -! -#ifndef INTERNAL_FILE_NML - inquire (file=trim(Model%fn_nml),exist=exists) - if (.not. exists) then - write(6,*) 'gcycle:: namelist file: ',trim(Model%fn_nml),' does not exist' - stop - else - open (unit=Model%nlunit, file=trim(Model%fn_nml), action='READ', status='OLD', iostat=ios) - rewind (Model%nlunit) - endif -#endif - CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & - Model%idate(4), Model%idate(2), & - Model%idate(3), Model%idate(1), & - Model%phour, RLA, RLO, SLMASK, & -! Model%fhour, RLA, RLO, SLMASK, & - OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & - SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & - VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, & - SNOFCS, ZORFCS, ALBFC1, TG3FCS, CNPFCS, & - SMCFC1, STCFC1, SLIFCS, AISFCS, & - VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & - CVBFCS, CVTFCS, Model%me, Model%nlunit, & - size(Model%input_nml_file), & - Model%input_nml_file, & - Model%ialb, Model%isot, Model%ivegsrc, & - trim(tile_num_ch), i_index, j_index) -#ifndef INTERNAL_FILE_NML - close (Model%nlunit) -#endif - - len = 0 - do nb = 1,nblks - do ix = 1,size(Grid(nb)%xlat,1) - len = len + 1 - Sfcprop(nb)%slmsk (ix) = SLIFCS (len) - if ( Model%nstf_name(1) > 0 ) then - Sfcprop(nb)%tref(ix) = TSFFCS (len) - else - Sfcprop(nb)%tsfc(ix) = TSFFCS (len) - endif - Sfcprop(nb)%weasd (ix) = SNOFCS (len) - Sfcprop(nb)%zorl (ix) = ZORFCS (len) - Sfcprop(nb)%tg3 (ix) = TG3FCS (len) - Sfcprop(nb)%canopy (ix) = CNPFCS (len) -! Sfcprop(nb)%f10m (ix) = F10MFCS (len) - Sfcprop(nb)%vfrac (ix) = VEGFCS (len) - Sfcprop(nb)%vtype (ix) = VETFCS (len) - Sfcprop(nb)%stype (ix) = SOTFCS (len) - Cldprop(nb)%cv (ix) = CVFCS (len) - Cldprop(nb)%cvb (ix) = CVBFCS (len) - Cldprop(nb)%cvt (ix) = CVTFCS (len) - Sfcprop(nb)%snowd (ix) = SWDFCS (len) - Sfcprop(nb)%hice (ix) = SIHFCS (len) - Sfcprop(nb)%fice (ix) = SICFCS (len) - Sfcprop(nb)%tisfc (ix) = SITFCS (len) - Sfcprop(nb)%shdmin (ix) = VMNFCS (len) - Sfcprop(nb)%shdmax (ix) = VMXFCS (len) - Sfcprop(nb)%slope (ix) = SLPFCS (len) - Sfcprop(nb)%snoalb (ix) = ABSFCS (len) - - Sfcprop(nb)%facsf (ix) = ALFFC1 (len ) - Sfcprop(nb)%facwf (ix) = ALFFC1 (len + npts) - - Sfcprop(nb)%alvsf (ix) = ALBFC1 (len ) - Sfcprop(nb)%alvwf (ix) = ALBFC1 (len + npts ) - Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) - Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) - do ls = 1,Model%lsoil - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) - enddo - ENDDO !-----END BLOCK SIZE LOOP------------------------------ - ENDDO !-----END BLOCK LOOP------------------------------- - -! check -! call mymaxmin(slifcs,len,len,1,'slifcs') -! -! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour - - RETURN - END diff --git a/physics/gscond.f b/physics/gscond.f deleted file mode 100644 index bfc6115fa..000000000 --- a/physics/gscond.f +++ /dev/null @@ -1,526 +0,0 @@ -!> \file gscond.f -!! This file contains the subroutine that calculates grid-scale -!! condensation and evaporation for use in Zhao and Carr (1997) -!! \cite zhao_and_carr_1997 scheme. - -!> This module contains the CCPP-compliant zhao_carr_gscond scheme. - module zhaocarr_gscond - contains - - -! \brief Brief description of the subroutine -! -!> \section arg_table_gscond_init Argument Table -!! - subroutine zhaocarr_gscond_init - end subroutine zhaocarr_gscond_init - -! \brief Brief description of the subroutine -! -!> \section arg_table_gscond_finalize Argument Table -!! - subroutine zhaocarr_gscond_finalize - end subroutine zhaocarr_gscond_finalize - -!> \defgroup condense GFS gscond Main -!> @{ -!! This subroutine computes grid-scale condensation and evaporation of -!! cloud condensate. -!! -#if 0 -!> \section arg_table_zhaocarr_gscond_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|----------------------------------------------------------------|-------------------------------------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!! | prsl | air_pressure | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | -!! | ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | clw1 | ice_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of ice water in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | in | F | -!! | clw2 | cloud_condensed_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | in | F | -!! | cwm | cloud_condensed_water_mixing_ratio_updated_by_physics | moist cloud condensed water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | -!! | t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | inout | F | -!! | tp | air_temperature_two_time_steps_back | air temperature two time steps back | K | 2 | real | kind_phys | inout | F | -!! | qp | water_vapor_specific_humidity_two_time_steps_back | water vapor specific humidity two time steps back | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | psp | surface_air_pressure_two_time_steps_back | surface air pressure two time steps back | Pa | 1 | real | kind_phys | inout | F | -!! | tp1 | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | inout | F | -!! | qp1 | water_vapor_specific_humidity_at_previous_time_step | water vapor specific humidity at previous time step | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | psp1 | surface_air_pressure_at_previous_time_step | surface air surface pressure at previous time step | Pa | 1 | real | kind_phys | inout | F | -!! | u | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | -!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | -!! | ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -#endif -!> \section general_gscond GFS gscond Scheme General Algorithm -!! -# Calculate ice-water identification number \f$IW\f$ in order to make a distinction between -!! cloud water and cloud ice (table2 of Zhao and Carr (1997) \cite zhao_and_carr_1997). -!! -# Calculate the changes in \f$t\f$, \f$q\f$ and \f$p\f$ due to all the processes except microphysics. -!! -# Calculate cloud evaporation rate (\f$E_c\f$, eq. 19 of Zhao and Carr (1997)\cite zhao_and_carr_1997). -!! -# Calculate cloud condensation rate (\f$C_g\f$, eq.8 of Zhao and Carr (1997)\cite zhao_and_carr_1997). -!! -# Update \f$t\f$, \f$q\f$, \f$cwm\f$ due to cloud evaporation and condensation processes. -!> \section Zhao-Carr_cond_detailed GFS gscond Scheme Detailed Algorithm -!> @{ - subroutine zhaocarr_gscond_run (im,ix,km,dt,dtf,prsl,ps,q,clw1 & - &, clw2, cwm, t, tp, qp, psp & - &, tp1, qp1, psp1, u, lprnt, ipr, errmsg, errflg) - -! -! ****************************************************************** -! * * -! * subroutine for grid-scale condensation & evaporation * -! * for the mrf model at ncep. * -! * * -! ****************************************************************** -! * * -! * created by: q. zhao jan. 1995 * -! * modified by: h.-l. pan sep. 1998 * -! * modified by: s. moorthi aug. 1998, 1999, 2000 * -! * * -! * references: * -! * * -! ****************************************************************** -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, psat => con_psat, hvap => con_hvap, grav => con_g - &, hfus => con_hfus, ttp => con_ttp, rd => con_rd - &, cp => con_cp, eps => con_eps, epsm1 => con_epsm1 - &, rv => con_rv -! use namelist_def, only: nsdfi,fhdfi - implicit none -! -! Interface variables - integer, intent(in) :: im, ix, km, ipr - real(kind=kind_phys), intent(in) :: dt, dtf - real(kind=kind_phys), intent(in) :: prsl(ix,km), ps(im) - real(kind=kind_phys), intent(inout) :: q(ix,km) - real(kind=kind_phys), intent(in) :: clw1(ix,km), clw2(ix,km) - real(kind=kind_phys), intent(out) :: cwm(ix,km) - real(kind=kind_phys), intent(inout) :: t(ix,km) & - &, tp(ix,km), qp(ix,km), psp(im) & - &, tp1(ix,km), qp1(ix,km), psp1(im) - real(kind=kind_phys), intent(in) :: u(im,km) - logical, intent(in) :: lprnt -! - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -! Local variables - real (kind=kind_phys) h1 - &, d00, elwv, eliv - &, epsq - &, r, cpr, rcp - parameter (h1=1.e0, d00=0.e0 - &, elwv=hvap, eliv=hvap+hfus - &, epsq=2.e-12, r=rd - &, cpr=cp*r, rcp=h1/cp) -! - real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 -! - real (kind=kind_phys) qi(im), qint(im), ccrik, e0 - &, cond, rdt, us, cclimit, climit - &, tmt0, tmt15, qik, cwmik - &, ai, qw, u00ik, tik, pres, pp0, fi - &, at, aq, ap, fiw, elv, qc, rqik - &, rqikk, tx1, tx2, tx3, es, qs - &, tsq, delq, condi, cone0, us00, ccrik1 - &, aa, ab, ac, ad, ae, af, ag - &, el2orc, albycp -! real (kind=kind_phys) vprs(im) - integer iw(im,km), i, k, iwik -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! -!-----------------GFS interstitial in driver ---------------------------- - do i = 1,im - do k= 1,km - cwm(i,k) = clw1(i,k)+clw2(i,k) - enddo - enddo -!-----------------prepare constants for later uses----------------- -! - el2orc = hvap*hvap / (rv*cp) - albycp = hvap / cp -! write(0,*)' in gscond im=',im,' ix=',ix -! - rdt = h1/dt - us = h1 - cclimit = 1.0e-3 - climit = 1.0e-20 -! - do i = 1, im - iw(i,km) = d00 - enddo -! -! check for first time step -! -! if (tp(1,1) < 1.) then -! do k = 1, km -! do i = 1, im -! tp(i,k) = t(i,k) -! qp(i,k) = max(q(i,k),epsq) -! tp1(i,k) = t(i,k) -! qp1(i,k) = max(q(i,k),epsq) -! enddo -! enddo -! do i = 1, im -! psp(i) = ps(i) -! psp1(i) = ps(i) -! enddo -! endif -! -!************************************************************* -!> -# Begining of grid-scale condensation/evaporation loop (start of -!! k-loop, i-loop) -!************************************************************* -! -! do k = km-1,2,-1 - do k = km,1,-1 -! vprs(:) = 0.001 * fpvs(t(:,k)) ! fpvs in pa -!----------------------------------------------------------------------- -!------------------qw, qi and qint-------------------------------------- - do i = 1, im - tmt0 = t(i,k)-273.16 - tmt15 = min(tmt0,cons_m15) - qik = max(q(i,k),epsq) - cwmik = max(cwm(i,k),climit) -! -! ai = 0.008855 -! bi = 1.0 -! if (tmt0 .lt. -20.0) then -! ai = 0.007225 -! bi = 0.9674 -! end if -! -! the global qsat computation is done in pa - pres = prsl(i,k) -! -! qw = vprs(i) - qw = min(pres, fpvs(t(i,k))) -! - qw = eps * qw / (pres + epsm1 * qw) - qw = max(qw,epsq) -! qi(i) = qw *(bi+ai*min(tmt0,cons_0)) -! qint(i) = qw *(1.-0.00032*tmt15*(tmt15+15.)) - qi(i) = qw - qint(i) = qw -! if (tmt0 .le. -40.) qint(i) = qi(i) - -!> -# Compute ice-water identification number IW. -!!\n The distinction between cloud water and cloud ice is made by the -!! cloud identification number IW, which is zero for cloud water and -!! unity for cloud ice (Table 2 in Zhao and Carr (1997) -!! \cite zhao_and_carr_1997): -!! - All clouds are defined to consist of liquid water below the -!! freezing level (\f$T\geq 0^oC\f$) and of ice particles above the -!! \f$T=-15^oC\f$ level. -!! - In the temperature region between \f$-15^oC\f$ and \f$0^oC\f$, -!! clouds may be composed of liquid water or ice. If there are cloud -!! ice particles above this point at the previous or current time step, -!! or if the cloud at this point at the previous time step consists of -!! ice particles, then the cloud substance at this point is considered -!! to be ice particles because of the cloud seeding effect and the -!! memory of its content. Otherwise, all clouds in this region are -!! considered to contain supercooled cloud water. - -!-------------------ice-water id number iw------------------------------ - if(tmt0.lt.-15.0) then - u00ik = u(i,k) - fi = qik - u00ik*qi(i) - if(fi > d00.or.cwmik > climit) then - iw(i,k) = 1 - else - iw(i,k) = 0 - end if - end if -! - if(tmt0.ge.0.0) then - iw(i,k) = 0 - end if -! - if (tmt0 < 0.0 .and. tmt0 >= -15.0) then - iw(i,k) = 0 - if (k < km) then - if (iw(i,k+1) == 1 .and. cwmik > climit) iw(i,k) = 1 - endif - end if - enddo -!> -# Condensation and evaporation of cloud -!--------------condensation and evaporation of cloud-------------------- - do i = 1, im -!> - Compute the changes in t, q and p (\f$A_{t}\f$,\f$A_{q}\f$ and -!! \f$A_{p}\f$) caused by all the processes except grid-scale -!! condensation and evaporation. -!!\f[ -!! A_{t}=(t-tp)/dt -!!\f] -!!\f[ -!! A_{q}=(q-qp)/dt -!!\f] -!!\f[ -!! A_{p}=(prsl-\frac{prsl}{ps} \times psp)/dt -!!\f] -!------------------------at, aq and dp/dt------------------------------- - qik = max(q(i,k),epsq) - cwmik = max(cwm(i,k),climit) - iwik = iw(i,k) - u00ik = u(i,k) - tik = t(i,k) - pres = prsl(i,k) - pp0 = (pres / ps(i)) * psp(i) - at = (tik-tp(i,k)) * rdt - aq = (qik-qp(i,k)) * rdt - ap = (pres-pp0) * rdt -!> - Calculate the saturation specific humidity \f$q_{s}\f$ and the -!! relative humidity \f$f\f$ using IW. -!----------------the satuation specific humidity------------------------ - fiw = float(iwik) - elv = (h1-fiw)*elwv + fiw*eliv - qc = (h1-fiw)*qint(i) + fiw*qi(i) -! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i) -!----------------the relative humidity---------------------------------- - if(qc.le.1.0e-10) then - rqik=d00 - else - rqik = qik/qc - endif - -!> - According to Sundqvist et al. (1989) \cite sundqvist_et_al_1989, -!! estimate cloud fraction \f$b\f$ at a grid point from relative -!! humidity \f$f\f$ using the equation -!!\f[ -!! b=1-\left ( \frac{f_{s}-f}{f_{s}-u} \right )^{1/2} -!!\f] -!! for \f$f>u\f$; and \f$b=0\f$ for \f$f1.0\times10^{-3}\f$, condense water vapor -!! into cloud condensate (\f$C_{g}\f$). -!!\n Using \f$q=fq_{s}\f$, \f$q_{s}=\epsilon e_{s}/p\f$, and the -!! Clausius-Clapeyron equation \f$de_{s}/dT=\epsilon Le_{s}/RT^{2}\f$, -!! where \f$q_{s}\f$ is the saturation specific humidity,\f$e_{s}\f$ -!! is the saturation vapor pressure, \f$R\f$ is the specific gas -!! constant for dry air, \f$f\f$ is the relative humidity, and -!! \f$\epsilon=0.622\f$, the expression for \f$C_{g}\f$ has the form -!!\f[ -!! C_{g}=\frac{M-q_{s}f_{t}}{1+(f\epsilon L^{2}q_{s}/RC_{p}T^{2})}+E_{c} -!!\f] -!! where -!!\f[ -!! M=A_{q}-\frac{f\epsilon Lq_{s}}{RT^{2}}A_{t}+\frac{fq_{s}}{p}A_{p} -!!\f] -!! To close the system, an equation for the relative humidity tendency -!! \f$f_{t}\f$ was derived by Sundqvist et al.(1989) -!! \cite sundqvist_et_al_1989 using the hypothesis that the quantity -!! \f$M+E_{c}\f$ is divided into one part,\f$bM\f$,which condenses -!! in the already cloudy portion of a grid square, and another part, -!! \f$(1-b)M+E_{c}\f$,which is used to increase the relative humidity -!! of the cloud-free portion and the cloudiness in the square. The -!! equation is written as -!!\f[ -!! f_{t}=\frac{2(1-b)(f_{s}-u)[(1-b)M+E_{c}]}{2q_{s}(1-b)(f_{s}-u)+cwm/b} -!!\f] -!! - Check and correct if over condensation occurs. -!! - Update t, q and cwm (according to Eqs(6) and (7) in Zhao and Carr (1997) -!! \cite zhao_and_carr_1997) -!!\f[ -!! cwm=cwm+(C_{g}-E_{c})\times dt -!!\f] -!!\f[ -!! q=q-(C_{g}-E_{c})\times dt -!!\f] -!!\f[ -!! t=t+\frac{L}{C_{p}}(C_{g}-E_{c})\times dt -!!\f] -!!\n where \f$L\f$ is the latent heat of condensation/deposition, and -!! \f$C_{p}\f$ is the specific heat of air at constant pressure. - -!----------------cloud cover ratio ccrik-------------------------------- - if (rqik .lt. u00ik) then - ccrik = d00 - elseif(rqik.ge.us) then - ccrik = us - else - rqikk = min(us,rqik) - ccrik = h1-sqrt((us-rqikk)/(us-u00ik)) - endif -!-----------correct ccr if it is too small in large cwm regions-------- -! if(ccrik.ge.0.01.and.ccrik.le.0.2.and -! & .cwmik.ge.0.2e-3) then -! ccrik=min(1.0,cwmik*1.0e3) -! end if -!---------------------------------------------------------------------- -! if no cloud exists then evaporate any existing cloud condensate -!----------------evaporation of cloud water----------------------------- - e0 = d00 - if (ccrik <= cclimit.and. cwmik > climit) then -! -! first iteration - increment halved -! - tx1 = tik - tx3 = qik -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * es / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = 0.5 * (qs - tx3) * tsq / (tsq + el2orc * qs) -! - tx2 = delq - tx1 = tx1 - delq * albycp - tx3 = tx3 + delq -! -! second iteration -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * es / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = (qs - tx3) * tsq / (tsq + el2orc * qs) -! - tx2 = tx2 + delq - tx1 = tx1 - delq * albycp - tx3 = tx3 + delq -! -! third iteration -! - es = min(pres, fpvs(tx1)) - qs = u00ik * eps * es / (pres + epsm1*es) - tsq = tx1 * tx1 - delq = (qs - tx3) * tsq / (tsq + el2orc * qs) - tx2 = tx2 + delq -! - e0 = max(tx2*rdt, cons_0) -! if (lprnt .and. i .eq. ipr .and. k .eq. 34) -! & print *,' tx2=',tx2,' qc=',qc,' u00ik=',u00ik,' rqik=',rqik -! &,' cwmik=',cwmik,' e0',e0 - -! e0 = max(qc*(u00ik-rqik)*rdt, cons_0) - e0 = min(cwmik*rdt, e0) - e0 = max(cons_0,e0) - end if -! if cloud cover > 0.2 condense water vapor in to cloud condensate -!-----------the eqs. for cond. has been reorganized to reduce cpu------ - cond = d00 -! if (ccrik .gt. 0.20 .and. qc .gt. epsq) then - if (ccrik .gt. cclimit .and. qc .gt. epsq) then - us00 = us - u00ik - ccrik1 = 1.0 - ccrik - aa = eps*elv*pres*qik - ab = ccrik*ccrik1*qc*us00 - ac = ab + 0.5*cwmik - ad = ab * ccrik1 - ae = cpr*tik*tik - af = ae * pres - ag = aa * elv - ai = cp * aa - cond = (ac-ad)*(af*aq-ai*at+ae*qik*ap)/(ac*(af+ag)) -!-----------check & correct if over condensation occurs----------------- - condi = (qik -u00ik *qc*1.0)*rdt - cond = min(cond, condi) -!----------check & correct if supersatuation is too high---------------- -! qtemp=qik-max(0.,(cond-e0))*dt -! if(qc.le.1.0e-10) then -! rqtmp=0.0 -! else -! rqtmp=qtemp/qc -! end if -! if(rqtmp.ge.1.10) then -! cond=(qik-1.10*qc)*rdt -! end if -!----------------------------------------------------------------------- - cond = max(cond, d00) -!-------------------update of t, q and cwm------------------------------ - end if - cone0 = (cond-e0) * dt - cwm(i,k) = cwm(i,k) + cone0 -! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0 -! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k -! &,' cwm=',cwm(i,k) - t(i,k) = t(i,k) + elv*rcp*cone0 - q(i,k) = q(i,k) - cone0 - enddo ! end of i-loop! - enddo ! end of k-loop! -! -!********************************************************************* -!> -# End of the condensation/evaporation loop (end of i-loop,k-loop). -!********************************************************************* -! -!> -# Store \f$t\f$, \f$q\f$, \f$ps\f$ for next time step. - - if (dt > dtf+0.001) then ! three time level - do k = 1, km - do i = 1, im - tp(i,k) = tp1(i,k) - qp(i,k) = qp1(i,k) -! - tp1(i,k) = t(i,k) - qp1(i,k) = max(q(i,k),epsq) - enddo - enddo - do i = 1, im - psp(i) = psp1(i) - psp1(i) = ps(i) - enddo - else ! two time level scheme - tp1, qp1, psp1 not used - do k = 1, km -! write(0,*)' in gscond k=',k,' im=',im,' km=',km - do i = 1, im -! write(0,*)' in gscond i=',i - tp(i,k) = t(i,k) - qp(i,k) = max(q(i,k),epsq) -! qp(i,k) = q(i,k) - tp1(i,k) = tp(i,k) - qp1(i,k) = qp(i,k) - enddo - enddo - do i = 1, im - psp(i) = ps(i) - psp1(i) = ps(i) - enddo - endif -!----------------------------------------------------------------------- - return - end subroutine zhaocarr_gscond_run -!> @} -!> @} - end module zhaocarr_gscond diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 deleted file mode 100644 index 554a00e74..000000000 --- a/physics/module_MYNNSFC_wrapper.F90 +++ /dev/null @@ -1,362 +0,0 @@ -!> \file module_mynnsfc_wrapper.F90 -!! Contains all of the code related to running the MYNN surface layer scheme - - MODULE mynnsfc_wrapper - - contains - - subroutine mynnsfc_wrapper_init () - end subroutine mynnsfc_wrapper_init - - subroutine mynnsfc_wrapper_finalize () - end subroutine mynnsfc_wrapper_finalize - -!>\defgroup gsd_mynn_sfc GSD MYNN Surface Layer Scheme Module -!> \brief This scheme (1) performs pre-mynnsfc work, (2) runs the mynn sfc layer scheme, and (3) performs post-mynnsfc work -#if 0 -!! \section arg_table_mynnsfc_wrapper_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |---------------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | -!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | -!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | -!! | u | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | v | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | t3d | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qvsh | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | -!! | qc | cloud_condensed_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) | kg kg-1 | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | exner | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | -!! | tsq | t_prime_squared | temperature fluctuation squared | K2 | 2 | real | kind_phys | in | F | -!! | qsq | q_prime_squared | water vapor fluctuation squared | kg2 kg-2 | 2 | real | kind_phys | in | F | -!! | cov | t_prime_q_prime | covariance of temperature and moisture | K kg kg-1 | 2 | real | kind_phys | in | F | -!! | el_pbl | mixing_length | mixing length in meters | m | 2 | real | kind_phys | in | F | -!! | Sh3D | stability_function_for_heat | stability function for heat | none | 2 | real | kind_phys | in | F | -!! | QC_BL | subgrid_cloud_mixing_ratio_pbl | subgrid cloud cloud mixing ratio from PBL scheme | kg kg-1 | 2 | real | kind_phys | in | F | -!! | CLDFRA_BL | subgrid_cloud_fraction_pbl | subgrid cloud fraction from PBL scheme | frac | 2 | real | kind_phys | in | F | -!! | ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | PBLH | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | tsk | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | in | F | -!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | in | F | -!! | snowd | surface_snow_thickness_water_equivalent | water equivalent snow depth over land | mm | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | inout | F | -!! | ust | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | -!! | ustm | surface_friction_velocity_drag | friction velocity isolated for momentum only | m s-1 | 1 | real | kind_phys | inout | F | -!! | zol | surface_stability_parameter | monin obukhov surface stability parameter | none | 1 | real | kind_phys | inout | F | -!! | mol | theta_star | temperature flux divided by ustar (temperature scale) | K | 1 | real | kind_phys | inout | F | -!! | rmol | reciprocal_of_obukhov_length | one over obukhov length | m-1 | 1 | real | kind_phys | inout | F | -!! | fm | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity parameter for momentum | none | 1 | real | kind_phys | inout | F | -!! | fh | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity parameter for heat | none | 1 | real | kind_phys | inout | F | -!! | fm10 | Monin-Obukhov_similarity_function_for_momentum_at_10m | Monin-Obukhov similarity parameter for momentum | none | 1 | real | kind_phys | inout | F | -!! | fh2 | Monin-Obukhov_similarity_function_for_heat_at_2m | Monin-Obukhov similarity parameter for heat | none | 1 | real | kind_phys | inout | F | -!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | inout | F | -!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | inout | F | -!! | ch | surface_drag_wind_speed_for_momentum_in_air | momentum exchange coefficient | m s-1 | 1 | real | kind_phys | inout | F | -!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | inout | F | -!! | QFX | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | inout | F | -!! | lh | surface_latent_heat | latent heating at the surface (pos = up) | W m-2 | 1 | real | kind_phys | inout | F | -!! | flhc | surface_exchange_coefficient_for_heat | surface exchange coefficient for heat | W m-2 K-1 | 1 | real | kind_phys | inout | F | -!! | flqc | surface_exchange_coefficient_for_moisture | surface exchange coefficient for moisture | kg m-2 s-1 | 1 | real | kind_phys | inout | F | -!! | u10 | x_wind_at_10m | 10 meter u wind speed | m s-1 | 1 | real | kind_phys | inout | F | -!! | v10 | y_wind_at_10m | 10 meter v wind speed | m s-1 | 1 | real | kind_phys | inout | F | -!! | th2 | potential_temperature_at_2m | 2 meter potential temperature | K | 1 | real | kind_phys | inout | F | -!! | t2 | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | inout | F | -!! | q2 | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | wstar | surface_wind_enhancement_due_to_convection | surface wind enhancement due to convection | m s-1 | 1 | real | kind_phys | inout | F | -!! | chs2 | surface_exchange_coefficient_for_heat_at_2m | exchange coefficient for heat at 2 meters | m s-1 | 1 | real | kind_phys | inout | F | -!! | cqs2 | surface_exchange_coefficient_for_moisture_at_2m | exchange coefficient for moisture at 2 meters | m s-1 | 1 | real | kind_phys | inout | F | -!! | cda | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | -!! | cka | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | bl_mynn_cloudpdf | cloudpdf | flag to determine which cloud PDF to use | flag | 0 | integer | | in | F | -!! | icloud_bl | couple_sgs_clouds_to_radiation_flag | flag for coupling sgs clouds to radiation | flag | 0 | integer | | in | F | -!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | none | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -#endif -!###=================================================================== -SUBROUTINE mynnsfc_wrapper_run( & - & ix,im,levs, & - & iter,flag_init,flag_restart, & - & delt,dx, & - & u, v, t3d, qvsh, qc, prsl, phii,& - & exner, tsq, qsq, cov, sh3d, & - & el_pbl, qc_bl, cldfra_bl, & - & ps, PBLH, slmsk, TSK, & - & QSFC, snowd, & - & zorl,UST,USTM, ZOL,MOL,RMOL, & - & fm, fh, fm10, fh2, WSPD, br, ch,& - & HFLX, QFX, LH, FLHC, FLQC, & - & U10, V10, TH2, T2, Q2, & - & wstar, CHS2, CQS2, & - & cda, cka, stress, & -! & CP, G, ROVCP, R, XLV, & -! & SVP1, SVP2, SVP3, SVPT0, & -! & EP1,EP2,KARMAN, & - & icloud_bl, bl_mynn_cloudpdf, & - & lprnt, errmsg, errflg ) - - -! should be moved to inside the mynn: - use machine , only : kind_phys -! use funcphys, only : fpvs - - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps - - USE module_sf_mynn, only : SFCLAY_mynn - -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- -! --- constant parameters: -! real(kind=kind_phys), parameter :: rvovrd = r_v/r_d - real(kind=kind_phys), parameter :: karman = 0.4 -! real(kind=kind_phys), parameter :: XLS = 2.85E6 -! real(kind=kind_phys), parameter :: p1000mb = 100000. - real(kind=kind_phys), parameter :: SVP1 = 0.6112 - real(kind=kind_phys), parameter :: SVP2 = 17.67 - real(kind=kind_phys), parameter :: SVP3 = 29.65 - real(kind=kind_phys), parameter :: SVPT0 = 273.15 - -!------------------------------------------------------------------- -!For WRF: -!------------------------------------------------------------------- -! USE module_model_constants, only: & -! &karman, g, p1000mb, & -! &cp, r_d, r_v, rcp, xlv, xlf, xls, & -! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & -! &cpv, cliq, cice - -!------------------------------------------------------------------- -!For reference -! REAL , PARAMETER :: karman = 0.4 -! REAL , PARAMETER :: g = 9.81 -! REAL , PARAMETER :: r_d = 287. -! REAL , PARAMETER :: cp = 7.*r_d/2. -! REAL , PARAMETER :: r_v = 461.6 -! REAL , PARAMETER :: cpv = 4.*r_v -! REAL , PARAMETER :: cliq = 4190. -! REAL , PARAMETER :: Cice = 2106. -! REAL , PARAMETER :: rcp = r_d/cp -! REAL , PARAMETER :: XLS = 2.85E6 -! REAL , PARAMETER :: XLV = 2.5E6 -! REAL , PARAMETER :: XLF = 3.50E5 -! REAL , PARAMETER :: p1000mb = 100000. -! REAL , PARAMETER :: rvovrd = r_v/r_d -! REAL , PARAMETER :: SVP1 = 0.6112 -! REAL , PARAMETER :: SVP2 = 17.67 -! REAL , PARAMETER :: SVP3 = 29.65 -! REAL , PARAMETER :: SVPT0 = 273.15 -! REAL , PARAMETER :: EP_1 = R_v/R_d-1. -! REAL , PARAMETER :: EP_2 = R_d/R_v - - REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & - &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2, g_inv=1/g - - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! NAMELIST OPTIONS (INPUT): - INTEGER, INTENT(IN) :: & - & bl_mynn_cloudpdf, & - & icloud_bl - -!MISC CONFIGURATION OPTIONS - INTEGER, PARAMETER :: & - & spp_pbl = 0, & - & isftcflx = 0, & - & iz0tlnd = 0, & - & isfflx = 1 - -!MYNN-1D - REAL :: delt - INTEGER :: im, ix, levs - INTEGER :: iter, k, i, itimestep - LOGICAL :: flag_init,flag_restart,lprnt - INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - -!MYNN-3D - real(kind=kind_phys), dimension(im,levs+1) :: phii - real(kind=kind_phys), dimension(im,levs) :: & - & exner, PRSL, & - & u, v, t3d, qvsh, qc, & - & Sh3D, EL_PBL, EXCH_H, & - & qc_bl, cldfra_bl, & - & Tsq, Qsq, Cov - !LOCAL - real(kind=kind_phys), dimension(im,levs) :: & - & dz, rho, th, qv, & - & pattern_spp_pbl - -!MYNN-2D - real(kind=kind_phys), dimension(im) :: & - & dx, pblh, slmsk, tsk, qsfc, ps, & - & zorl, ust, ustm, hflx, qfx, br, wspd, snowd, & - & FLHC, FLQC, U10, V10, TH2, T2, Q2, & - & CHS2, CQS2, rmol, zol, mol, ch, & - & fm, fh, fm10, fh2, & - & lh, cda, cka, stress, wstar - !LOCAL - real, dimension(im) :: & - & qcg, hfx, znt, ts, snowh, psim, psih, & - & chs, ck, cd, mavail, regime, xland, GZ1OZ0 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (lprnt) then - write(0,*)"==============================================" - write(0,*)"in mynn surface layer wrapper..." - write(0,*)"flag_init=",flag_init - write(0,*)"flag_restart=",flag_restart - write(0,*)"iter=",iter - endif - - ! If initialization is needed and mynnsfc_wrapper is called - ! in a subcycling loop, then test for (flag_init==.T. .and. iter==1); - ! initialization in sfclay_mynn is triggered by itimestep == 1 - ! DH* TODO: Use flag_restart to distinguish which fields need - ! to be initialized and which are read from restart files - if (flag_init.and.iter==1) then - itimestep = 1 - else - itimestep = 2 - endif - - !prep MYNN-only variables - do k=1,levs - do i=1,im - dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv - th(i,k)=t3d(i,k)/exner(i,k) - !qc(i,k)=MAX(qgrs(i,k,ntcw),0.0) - qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) - rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) !gt0(i,k)) - pattern_spp_pbl(i,k)=0.0 - enddo - enddo - do i=1,im - if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 - xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn - else - xland(i)=2.0 - endif -! ust(i) = sqrt(stress(i)) - !ch(i)=0.0 - HFX(i)=hflx(i)*rho(i,1)*cp - !QFX(i)=evap(i) - !wstar(i)=0.0 - qcg(i)=0.0 - snowh(i)=snowd(i)*800. !mm -> m - znt(i)=zorl(i)*0.01 !cm -> m? - ts(i)=tsk(i)/exner(i,1) !theta -! qsfc(i)=qss(i) -! ps(i)=pgr(i) -! wspd(i)=wind(i) - mavail(i)=1.0 !???? - enddo - - if (lprnt) then - write(0,*)"CALLING SFCLAY_mynn; input:" - print*,"T:",t3d(1,1),t3d(1,2),t3d(1,3) - print*,"TH:",th(1,1),th(1,2),th(1,3) - print*,"rho:",rho(1,1),rho(1,2),rho(1,3) - print*,"u:",u(1,1:3) - !print*,"qv:",qv(1,1:3,1) - print*,"p:",prsl(1,1)," snowh=",snowh(1) - print*,"dz:",dz(1,1)," qsfc=",qsfc(1) - print*,"rmol:",rmol(1)," ust:",ust(1) - print*,"Tsk:",tsk(1)," Thetasurf:",ts(1) - print*,"HFX:",hfx(1)," qfx",qfx(1) - print*,"qsfc:",qsfc(1)," ps:",ps(1) - print*,"wspd:",wspd(1),"br=",br(1) - print*,"znt:",znt(1)," delt=",delt - print*,"im=",im," levs=",levs - print*,"flag_init=",flag_init !," ntcw=",ntcw!," ntk=",ntk - print*,"flag_restart=",flag_restart !," ntcw=",ntcw!," ntk=",ntk - print*,"iter=",iter - !print*,"ncld=",ncld," ntrac(gq0)=",ntrac - print*,"zlvl(1)=",dz(1,1)*0.5 - print*,"PBLH=",pblh(1)," xland=",xland(1) - endif - - - CALL SFCLAY_mynn( & - u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & - CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & - PSFCPA=ps,CHS=chs,CHS2=chs2,CQS2=cqs2, & - ZNT=znt,UST=ust,PBLH=pblh,MAVAIL=mavail, & - ZOL=zol,MOL=mol,REGIME=regime,psim=psim,psih=psih, & - psix=fm,psit=fh,psix10=fm10,psit2=fh2, & -! fm=psix,fh=psit,fm10=psix10,fh2=psit2, & - XLAND=xland,HFX=hfx,QFX=qfx,LH=lh,TSK=tsk, & - FLHC=flhc,FLQC=flqc,QSFC=qsfc,RMOL=rmol, & - U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2,SNOWH=snowh, & - GZ1OZ0=GZ1OZ0,WSPD=wspd,BR=br,ISFFLX=isfflx,DX=dx, & - SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & - EP1=ep_1,EP2=ep_2,KARMAN=karman, & - itimestep=itimestep,ch=ch, & - th3d=th,pi3d=exner,qc3d=qc,rho3d=rho, & - tsq=tsq,qsq=qsq,cov=cov,sh3d=sh3d,el_pbl=el_pbl, & - qcg=qcg,wstar=wstar, & - icloud_bl=icloud_bl,qc_bl=qc_bl,cldfra_bl=cldfra_bl, & - spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & - ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & - ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & - its=1,ite=im, jts=1,jte=1, kts=1,kte=levs, & - ustm=ustm, ck=ck, cka=cka, cd=cd, cda=cda, & - isftcflx=isftcflx, iz0tlnd=iz0tlnd, & - bl_mynn_cloudpdf=bl_mynn_cloudpdf ) - - - ! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK: - do i = 1, im - hflx(i)=hfx(i)/(rho(i,1)*cp) - !QFX(i)=evap(i) - zorl(i)=znt(i)*100. !m -> cm - stress(i) = ust(i)**2 - enddo - - - if (lprnt) then - print* - print*,"finished with mynn_surface layer; output:" - print*,"xland=",xland(1)," cda=",cda(1) - print*,"rmol:",rmol(1)," ust:",ust(1) - print*,"Tsk:",tsk(1)," Thetasurf:",ts(1) - print*,"HFX:",hfx(1)," qfx",qfx(1) - print*,"qsfc:",qsfc(1)," ps:",ps(1) - print*,"wspd:",wspd(1)," br=",br(1) - print*,"znt:",znt(1),"pblh:",pblh(1) - print*,"FLHC=",FLHC(1)," CHS=",CHS(1) - print* - endif - - - END SUBROUTINE mynnsfc_wrapper_run - -!###================================================================= - -END MODULE mynnsfc_wrapper diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 deleted file mode 100644 index 70b98363d..000000000 --- a/physics/module_sf_mynn.F90 +++ /dev/null @@ -1,2446 +0,0 @@ -!>\file module_sf_mynn.F90 -!! This file contains -!WRF:MODEL_LAYER:PHYSICS -! -!>\ingroup gsd_mynn_sfc -!>\defgroup module_sf_mynn_mod GSD MYNN SFC Module -MODULE module_sf_mynn - -!------------------------------------------------------------------- -!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES -!for WRFv3.4, v3.4.1, v3.5.1, v3.6, v3.7.1, and v3.9: -! -! BOTH LAND AND WATER: -!1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) -! for first iteration of first time step; afterwards, exact calculation. -!2) Fixed isfflx=0 option to turn off scalar fluxes, but keep momentum -! fluxes for idealized studies (credit: Anna Fitch). -!3) Kinematic viscosity now varies with temperature -!4) Uses Monin-Obukhov flux-profile relationships more consistent with -! those used in the MYNN PBL code. -!5) Allows negative QFX, similar to MYJ scheme -! -! LAND only: -!1) iz0tlnd option is now available with the following options: -! (default) =0: Zilitinkevich (1995) -! =1: Czil_new (modified according to Chen & Zhang 2008) -! =2: Modified Yang et al (2002, 2008) - generalized for all landuse -! =3: constant zt = z0/7.4 (original form; Garratt 1992) -! =4: Pan et al. (1994) with RUC mods for z_q, zili for z_t -!2) Relaxed u* minimum from 0.1 to 0.01 -! -! WATER only: -!1) isftcflx option is now available with the following options: -! (default) =0: z0, zt, and zq from the COARE algorithm. Set COARE_OPT (below) to -! 3.0 (Fairall et al. 2003, default) -! 3.5 (Edson et al 2013) -! =1: z0 from Davis et al (2008), zt & zq from COARE 3.0/3.5 -! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 -! -! SNOW/ICE only: -!1) Added Andreas (2002) snow/ice parameterization for thermal and -! moisture roughness to help reduce the cool/moist bias in the arctic -! region. Also added a z0 mod for snow (Andreas et al. 2005, BLM), which -! -! Misc: -! 2) added a more elaborate diagnostic for u10 & V10 for high vertical resolution -! model configurations. -! -! New for v3.9: -! - option for stochastic parameter perturbations (SPP) -! -!NOTE: This code was primarily tested in combination with the RUC LSM. -! Performance with the Noah (or other) LSM is relatively unknown. -!------------------------------------------------------------------- -!For WRF -! USE module_model_constants, only: & -! &g, p1000mb, cp, xlv, ep_2, r_d, r_v, rcp, cpv -! - USE module_bl_mynn, only: tv0, b1, b2, p608, ev, rd, & !, mym_condensation - &esat_blend, xl_blend, qsat_blend - - use physcons, only : cp => con_cp, & - & g => con_g, & - & r_d => con_rd, & - & r_v => con_rv, & - & cpv => con_cvap, & - & cliq => con_cliq, & - & Cice => con_csol, & - & rcp => con_rocp, & - & XLV => con_hvap, & - & XLF => con_hfus, & - & EP_1 => con_fvirt, & - & EP_2 => con_eps - -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!For non-WRF -! REAL , PARAMETER :: g = 9.81 -! REAL , PARAMETER :: r_d = 287. -! REAL , PARAMETER :: cp = 7.*r_d/2. -! REAL , PARAMETER :: r_v = 461.6 -! REAL , PARAMETER :: cpv = 4.*r_v -! REAL , PARAMETER :: rcp = r_d/cp -! REAL , PARAMETER :: XLV = 2.5E6 -! REAL , PARAMETER :: XLF = 3.50E5 - REAL , PARAMETER :: p1000mb = 100000. -! REAL , PARAMETER :: EP_2 = r_d/r_v - - - - REAL, PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2 - REAL, PARAMETER :: wmin=0.1 ! Minimum wind speed - REAL, PARAMETER :: VCONVC=1.25 - REAL, PARAMETER :: SNOWZ0=0.011 - REAL, PARAMETER :: COARE_OPT=3.0 ! 3.0 or 3.5 - !For debugging purposes: - LOGICAL, PARAMETER :: debug_code = .false. - -CONTAINS - -!------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> Fill the PSIM and PSIH tables. The subroutine "sfclayinit". -!! can be found in module_sf_sfclay.F. This subroutine returns -!! the forms from Dyer and Hicks (1974). - SUBROUTINE mynn_sf_init_driver(allowed_to_read) - - LOGICAL, INTENT(in) :: allowed_to_read - -! CALL sfclayinit(allowed_to_read) - - END SUBROUTINE mynn_sf_init_driver - -!------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!! This subroutine - SUBROUTINE SFCLAY_mynn( & - U3D,V3D,T3D,QV3D,P3D,dz8w, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2, & - ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME, & - PSIM,PSIH,PSIX,PSIX10,PSIT,PSIT2, & - XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QSFC,RMOL, & - U10,V10,TH2,T2,Q2,SNOWH, & - GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d, & - tsq,qsq,cov,sh3d,el_pbl,qcg,wstar, & - icloud_bl,qc_bl,cldfra_bl, & - spp_pbl,pattern_spp_pbl, & - 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, & - bl_mynn_cloudpdf) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- T3D 3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -!-- P3D 3D pressure (Pa) -!-- RHO3D 3D density (kg/m3) -!-- dz8w 3D 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) -!-- PSFCPA surface pressure (Pa) -!-- ZNT roughness length (m) -!-- UST u* in similarity theory (m/s) -!-- USTM u* in similarity theory (m/s) w* added to WSPD. This is -! used to couple with TKE scheme but not in MYNN. -! (as of now, USTM = UST in this version) -!-- 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) -!-- RMOL Reciprocal of M-O length (/m) -!-- REGIME flag indicating PBL regime (stable, unstable, etc.) -!-- PSIM similarity stability function for momentum -!-- PSIH similarity 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 qv (specific humidity) at the surface -!-- QSFCMR qv (mixing ratio) at the surface -!-- 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) -!-- SNOWH Snow height (m) -!-- GZ1OZ0 log((z1+ZNT)/ZNT) where ZNT 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 (=0.6112 kPa) -!-- SVP2 constant for saturation vapor pressure (=17.67 dimensionless) -!-- SVP3 constant for saturation vapor pressure (=29.65 K) -!-- SVPT0 constant for saturation vapor pressure (=273.15 K) -!-- EP1 constant for virtual temperature (Rv/Rd - 1) (dimensionless) -!-- EP2 constant for spec. hum. calc (Rd/Rv = 0.622) (dimensionless) -!-- EP3 constant for spec. hum. calc (1 - Rd/Rv = 0.378 ) (dimensionless) -!-- KARMAN Von Karman constant -!-- 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: z0, zt, and zq from COARE3.0/3.5 (Fairall et al 2003/Edson et al 2013) -! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5 -! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 -!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.10, -! (land =1: Czil_new (modified according to Chen & Zhang 2008) -! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse -! =3: constant zt = z0/7.4 (Garratt 1992) -! =4: Pan et al (1994) for zq; ZIlitintevich for zt -!-- bl_mynn_cloudpdf =0: Mellor & Yamada -! =1: Kuwano et al. -!-- el_pbl = mixing length from PBL scheme (meters) -!-- Sh3d = Stability finction for heat (unitless) -!-- cov = T'q' from PBL scheme -!-- tsq = T'T' from PBL scheme -!-- qsq = q'q' from PBL scheme -!-- icloud_bl = namelist option for subgrid scale cloud/radiation feedback -!-- qc_bl = subgrid scale (bloundary layer) clouds -!-- cldfra_bl = subgridscale cloud fraction -! -!-- 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 -!================================================================= -! SCALARS -!=================================== - 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) :: SVP1,SVP2,SVP3,SVPT0 - REAL, INTENT(IN) :: EP1,EP2,KARMAN - REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX -!NAMELIST OPTIONS: - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND,& - bl_mynn_cloudpdf,& - icloud_bl - INTEGER, INTENT(IN),OPTIONAL :: spp_pbl - -!=================================== -! 3D VARIABLES -!=================================== - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(IN ) :: dz8w, & - QV3D, & - P3D, & - T3D, & - QC3D, & - U3D,V3D, & - RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_bl, & - cldfra_bl - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl -!=================================== -! 2D VARIABLES -!=================================== - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: MAVAIL, & - PBLH, & - XLAND, & - TSK, & - QCG, & - PSFCPA, & - SNOWH, & - DX - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT ) :: U10,V10, & - TH2,T2,Q2 - - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm -! - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: REGIME, & - HFX, & - QFX, & - LH, & - MOL,RMOL, & - QSFC, & - ZNT, & - ZOL, & - UST, & - CHS2, & - CQS2, & - CHS, & - CH, & - FLHC,FLQC, & - GZ1OZ0,WSPD,BR, & - PSIM,PSIH, & - WSTAR, & - PSIX,PSIX10,PSIT,PSIT2 - -!ADDITIONAL OUTPUT -!JOE-begin - REAL, DIMENSION( ims:ime, jms:jme ) :: z0zt_ratio, & - BulkRi,qstar,resist,logres -!JOE-end -!=================================== -! 1D LOCAL ARRAYS -!=================================== - REAL, DIMENSION( its:ite ) :: U1D, & - V1D, & - U1D2,V1D2, & !level2 winds - QV1D, & - P1D, & - T1D,QC1D, & - RHO1D, & - dz8w1d, & !level 1 height - dz2w1d !level 2 height - - REAL, DIMENSION( its:ite ) :: rstoch1D - - ! VARIABLE FOR PASSING TO MYM_CONDENSATION - REAL, DIMENSION(kts:kts+1 ) :: dummy1,dummy2,dummy3,dummy4, & - dummy5,dummy6,dummy7,dummy8, & - dummy9,dummy10,dummy11, & - dummy12,dummy13,dummy14 - - REAL, DIMENSION( its:ite ) :: vt1,vq1 - REAL, DIMENSION(kts:kts+1) :: thl, qw, vt, vq - REAL :: ql - - INTEGER :: I,J,K,itf,jtf,ktf -!----------------------------------------------------------- -!joe -test printing of constants: -! print*,"cp=", cp -! print*,"g=", g -! print*,"Rd=", r_d -! print*,"Rv=", r_v -! print*,"cpc=", cpv -! print*,"cliq=", cliq -! print*,"cice=", Cice -! print*,"rcp=", rcp -! print*,"xlv=", XLV -! print*,"xlf=", XLF -! print*,"ep1=", EP_1 -! print*,"ep2=", EP_2 - - - itf=ite !MIN0(ite,ide-1) - jtf=jte !MIN0(jte,jde-1) - ktf=kte !MIN0(kte,kde-1) - - DO J=jts,jte - DO i=its,ite - dz8w1d(I) = dz8w(i,kts,j) - dz2w1d(I) = dz8w(i,kts+1,j) - U1D(i) =U3D(i,kts,j) - V1D(i) =V3D(i,kts,j) - !2nd model level winds - for diags with high-res grids - U1D2(i) =U3D(i,kts+1,j) - V1D2(i) =V3D(i,kts+1,j) - QV1D(i)=QV3D(i,kts,j) - QC1D(i)=QC3D(i,kts,j) - P1D(i) =P3D(i,kts,j) - T1D(i) =T3D(i,kts,j) - RHO1D(i)=RHO3D(i,kts,j) - if (spp_pbl==1) then - rstoch1D(i)=pattern_spp_pbl(i,kts,j) - else - rstoch1D(i)=0.0 - endif - ENDDO - - IF (itimestep==1) THEN - DO i=its,ite - vt1(i)=0. - vq1(i)=0. - UST(i,j)=MAX(0.025*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) - MOL(i,j)=0. ! Tstar - QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j)) - qstar(i,j)=0.0 - ENDDO - ELSE - DO i=its,ite - DO k = kts,kts+1 - ql = qc3d(i,k,j)/(1.+qc3d(i,k,j)) - qw(k) = qv3d(i,k,j)/(1.+qv3d(i,k,j)) + ql - thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j) - dummy1(k)=dz8w(i,k,j) - dummy2(k)=thl(k) - dummy3(k)=qw(k) - dummy4(k)=p3d(i,k,j) - dummy5(k)=pi3d(i,k,j) - dummy6(k)=tsq(i,k,j) - dummy7(k)=qsq(i,k,j) - dummy8(k)=cov(i,k,j) - dummy9(k)=Sh3d(i,k,j) - dummy10(k)=el_pbl(i,k,j) - dummy14(k)=th3d(i,k,j) - if(icloud_bl > 0) then - dummy11(k)=qc_bl(i,k,j) - dummy12(k)=cldfra_bl(i,k,j) - else - dummy11(k)=0.0 - dummy12(k)=0.0 - endif - dummy13(k)=0.0 !sgm - ENDDO - - ! NOTE: The last grid number is kts+1 instead of kte. - CALL mym_condensation (kts,kts+1, dx(i,j),& - & dummy1,dummy2,dummy3, & - & dummy4,dummy5,dummy6, & - & dummy7,dummy8,dummy9, & - & dummy10,bl_mynn_cloudpdf,& - & dummy11,dummy12, & - & PBLH(i,j),HFX(i,j), & - & vt(kts:kts+1), vq(kts:kts+1), & - & dummy14,dummy13) - -! ! NOTE: The last grid number is kts+1 instead of kte. -! CALL mym_condensation (kts,kts+1, dx, & -! & dz8w(i,kts:kts+1,j), & -! & thl(kts:kts+1), & -! & qw(kts:kts+1), & -! & p3d(i,kts:kts+1,j), & -! & pi3d(i,kts:kts+1,j), & -! & tsq(i,kts:kts+1,j), & -! & qsq(i,kts:kts+1,j), & -! & cov(i,kts:kts+1,j), & -! & Sh3d(i,kts:kts+1,j), & !JOE - cloud PDF testing -! & el_pbl(i,kts:kts+1,j), & !JOE - cloud PDF testing -! & bl_mynn_cloudpdf, & !JOE - cloud PDF testing -! & qc_bl2D(i,kts:kts+1), & !JOE-subgrid BL clouds -! & cldfra_bl2D(i,kts:kts+1),& !JOE-subgrid BL clouds -! & PBLH(i,j),HFX(i,j), & !JOE-subgrid BL clouds -! & vt(kts:kts+1), vq(kts:kts+1), & - ! & th,sgm) - vt1(i) = vt(kts) - vq1(i) = vq(kts) - ENDDO - ENDIF - - CALL SFCLAY1D_mynn( & - J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & - U1D2,V1D2,dz2w1d, & - CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),& - CQS2(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), & - PSIX(ims,j),PSIX10(ims,j),PSIT(ims,j),PSIT2(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),SNOWH(ims,j), & - QSFC(ims,j),LH(ims,j), & - GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX(ims,j),& - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & - ch(ims,j),vt1,vq1,qc1d,qcg(ims,j), & - itimestep, & -!JOE-begin additional output - z0zt_ratio(ims,j),wstar(ims,j), & - qstar(ims,j),resist(ims,j),logres(ims,j), & -!JOE-end - spp_pbl,rstoch1D, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ,isftcflx,iz0tlnd, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j) & - ) - - ENDDO - - END SUBROUTINE SFCLAY_MYNN - -!------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!! This subroutine calculates - SUBROUTINE SFCLAY1D_mynn( & - J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & - U1D2,V1D2,dz2w1d, & - CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2, & - PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME, & - PSIM,PSIH,PSIX,PSIX10,PSIT,PSIT2, & - XLAND,HFX,QFX,TSK, & - U10,V10,TH2,T2,Q2,FLHC,FLQC,SNOWH, & - QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,ch,vt1,vq1,qc1d,qcg, & - itimestep, & -!JOE-additional output - zratio,wstar,qstar,resist,logres, & -!JOE-end - spp_pbl,rstoch1D, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte & - ,isftcflx, iz0tlnd, & - ustm,ck,cka,cd,cda & - ) - -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! SCALARS -!----------------------------- - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - J, itimestep - - REAL, PARAMETER :: XKA=2.4E-5 !molecular diffusivity - REAL, PARAMETER :: PRT=1. !prandlt number - REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 - REAL, INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX - -!----------------------------- -! NAMELIST OPTIONS -!----------------------------- - INTEGER, INTENT(IN) :: ISFFLX - INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND - INTEGER, INTENT(IN) :: spp_pbl - -!----------------------------- -! 1D ARRAYS -!----------------------------- - REAL, DIMENSION( ims:ime ), INTENT(IN) :: MAVAIL, & - PBLH, & - XLAND, & - TSK, & - PSFCPA, & - QCG, & - SNOWH, DX - - REAL, DIMENSION( its:ite ), INTENT(IN) :: U1D,V1D, & - U1D2,V1D2, & - QV1D,P1D, & - T1D,QC1d, & - dz8w1d,dz2w1d, & - RHO1D, & - vt1,vq1 - - REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: REGIME, & - HFX,QFX,LH, & - MOL,RMOL, & - QSFC, & - ZNT, & - ZOL, & - UST, & - CHS2,CQS2, & - CHS,CH, & - FLHC,FLQC, & - GZ1OZ0, & - WSPD, & - BR, & - PSIM,PSIH, & - PSIX,PSIX10,PSIT,PSIT2 - - REAL, DIMENSION( its:ite ), INTENT(IN) :: rstoch1D - - ! DIAGNOSTIC OUTPUT - REAL, DIMENSION( ims:ime ), INTENT(OUT) :: U10,V10, & - TH2,T2,Q2 - - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm -!-------------------------------------------- -!JOE-additinal output - REAL, DIMENSION( ims:ime ) :: zratio,wstar,qstar, & - resist,logres -!JOE-end -!---------------------------------------------------------------- -! LOCAL VARS -!---------------------------------------------------------------- - REAL :: thl1,sqv1,sqc1,exner1,sqvg,sqcg,vv,ww - - REAL, DIMENSION(its:ite) :: & - ZA, & !Height of lowest 1/2 sigma level(m) - ZA2, & !Height of 2nd lowest 1/2 sigma level(m) - THV1D, & !Theta-v at lowest 1/2 sigma (K) - TH1D, & !Theta at lowest 1/2 sigma (K) - TC1D, & !T at lowest 1/2 sigma (Celsius) - TV1D, & !Tv at lowest 1/2 sigma (K) - QVSH, & !qv at lowest 1/2 sigma (spec humidity) - PSIH2,PSIM2, & !M-O stability functions at z=2 m - PSIH10,PSIM10, & !M-O stability functions at z=10 m - WSPDI, & - CPM, & - z_t,z_q, & !thermal & moisture roughness lengths - ZNTstoch, & - GOVRTH, & !g/theta - THGB, & !theta at ground - THVGB, & !theta-v at ground - PSFC, & !press at surface (Pa/1000) - QSFCMR, & !qv at surface (mixing ratio, kg/kg) - GZ2OZ0, & !LOG((2.0+ZNT(I))/ZNT(I)) - GZ10OZ0, & !LOG((10.+ZNT(I))/ZNT(I)) - GZ2OZt, & !LOG((2.0+z_t(i))/z_t(i)) - GZ10OZt, & !LOG((10.+z_t(i))/z_t(i)) - GZ1OZt !LOG((ZA(I)+z_t(i))/z_t(i)) - - INTEGER :: N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER, yesno - INTEGER, PARAMETER :: ITMAX=1 - - REAL :: PL,THCON,TVCON,E1 - REAL :: DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 - REAL :: DTG,DTTHX,DTHDZ,PSIT10,PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD - REAL :: restar,VISC,DQG,OLDUST,OLDTST - REAL, PARAMETER :: psilim = -10. ! ONLY AFFECTS z/L > 2.0 -!------------------------------------------------------------------- - - DO I=its,ite - ! CONVERT GROUND & LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: - ! PSFC cmb - PSFC(I)=PSFCPA(I)/1000. - THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP !(K) - ! PL cmb - PL=P1D(I)/1000. - THCON=(100./PL)**ROVCP - TH1D(I)=T1D(I)*THCON !(Theta, K) - TC1D(I)=T1D(I)-273.15 !(T, Celsius) - - ! CONVERT TO VIRTUAL TEMPERATURE - QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) - TVCON=(1.+EP1*QVSH(I)) - THV1D(I)=TH1D(I)*TVCON !(K) - TV1D(I)=T1D(I)*TVCON !(K) - - !RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver - ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level - ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level - GOVRTH(I)=G/TH1D(I) - ENDDO - - DO I=its,ite - IF (TSK(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) - E1=SVP1*EXP(4648*(1./273.15 - 1./TSK(I)) - & - & 11.64*LOG(273.15/TSK(I)) + 0.02265*(273.15 - TSK(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(TSK(I)-SVPT0)/(TSK(I)-SVP3)) - ENDIF - !FOR LAND POINTS, QSFC can come from LSM, ONLY RECOMPUTE OVER WATER - IF (xland(i).gt.1.5 .or. QSFC(i).le.0.0) THEN !WATER - QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity - QSFCMR(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio - ELSE !LAND - QSFCMR(I)=QSFC(I)/(1.-QSFC(I)) - ENDIF - - IF (TSK(I) .LT. 273.15) THEN - !SATURATION VAPOR PRESSURE WRT ICE - E1=SVP1*EXP(4648*(1./273.15 - 1./T1D(I)) - & - & 11.64*LOG(273.15/T1D(I)) + 0.02265*(273.15 - T1D(I))) - ELSE - !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) - E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) - ENDIF - PL=P1D(I)/1000. - CPM(I)=CP*(1.+0.84*QV1D(I)) - ENDDO - - DO I=its,ite - WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)) - - !account for partial condensation - exner1=(p1d(I)/p1000mb)**ROVCP - sqc1=qc1d(I)/(1.+qc1d(I)) !lowest mod level cloud water spec hum - sqv1=QVSH(I) !lowest mod level water vapor spec hum - thl1=TH1D(I)-xlvcp/exner1*sqc1 - sqvg=qsfc(I) !sfc water vapor spec hum - sqcg=qcg(I)/(1.+qcg(I)) !sfc cloud water spec hum - - vv = thl1-THGB(I) - !TGS:ww = mavail(I)*(sqv1-sqvg) + (sqc1-sqcg) - ww = (sqv1-sqvg) + (sqc1-sqcg) - - !TGS:THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) - THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)) - - DTHDZ=(TH1D(I)-THGB(I)) - DTHVDZ=(THV1D(I)-THVGB(I)) - !DTHVDZ= (vt1(i) + 1.0)*vv + (vq1(i) + tv0)*ww - - !-------------------------------------------------------- - ! Calculate the convective velocity scale (WSTAR) and - ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) - ! and Mahrt and Sun (1995, MWR), respectively - !------------------------------------------------------- - ! Use Beljaars over land and water - fluxc = max(hfx(i)/RHO1D(i)/cp & - & + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.) - WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**.33 - - !-------------------------------------------------------- - ! Mahrt and Sun low-res correction - ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) - !-------------------------------------------------------- - VSGD = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 - WSPD(I)=SQRT(WSPD(I)*WSPD(I)+WSTAR(I)*WSTAR(I)+vsgd*vsgd) - WSPD(I)=MAX(WSPD(I),wmin) - - !-------------------------------------------------------- - ! CALCULATE THE BULK RICHARDSON NUMBER OF SURFACE LAYER, - ! ACCORDING TO AKB(1976), EQ(12). - !-------------------------------------------------------- - BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) - !SET LIMITS ACCORDING TO Li et al. (2010) Boundary-Layer Meteorol (p.158) - BR(I)=MAX(BR(I),-20.0) - BR(I)=MIN(BR(I),2.0) - - ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) - !if (itimestep .GT. 1) THEN - ! IF(MOL(I).LT.0.)BR(I)=MIN(BR(I),0.0) - !ENDIF - - !IF(I .eq. 2)THEN - ! write(*,1006)"BR:",BR(I)," fluxc:",fluxc," vt1:",vt1(i)," vq1:",vq1(i) - ! write(*,1007)"XLAND:",XLAND(I)," WSPD:",WSPD(I)," DTHVDZ:",DTHVDZ," WSTAR:",WSTAR(I) - !ENDIF - - ENDDO - - 1006 format(A,F7.3,A,f9.4,A,f9.5,A,f9.4) - 1007 format(A,F2.0,A,f6.2,A,f7.3,A,f7.2) - -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- -!--- BEGIN ITERATION LOOP (ITMAX=5); USUALLY CONVERGES IN TWO PASSES -!-------------------------------------------------------------------- -!-------------------------------------------------------------------- - - DO I=its,ite - - ITER = 1 - DO WHILE (ITER .LE. ITMAX) - - !COMPUTE KINEMATIC VISCOSITY (m2/s) Andreas (1989) CRREL Rep. 89-11 - !valid between -173 and 277 degrees C. - VISC=1.326e-5*(1. + 6.542e-3*TC1D(I) + 8.301e-6*TC1D(I)*TC1D(I) & - - 4.84e-9*TC1D(I)*TC1D(I)*TC1D(I)) - - IF((XLAND(I)-1.5).GE.0)THEN - !-------------------------------------- - ! WATER - !-------------------------------------- - ! CALCULATE z0 (znt) - !-------------------------------------- - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX .EQ. 0 ) THEN - IF (COARE_OPT .EQ. 3.0) THEN - !COARE 3.0 (MISLEADING SUBROUTINE NAME) - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ELSE - !COARE 3.5 - CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ENDIF - ELSEIF ( ISFTCFLX .EQ. 1 .OR. ISFTCFLX .EQ. 2 ) THEN - CALL davis_etal_2008(ZNT(i),UST(i)) - ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - CALL Taylor_Yelland_2001(ZNT(i),UST(i),WSPD(i)) - ELSEIF ( ISFTCFLX .EQ. 4 ) THEN - IF (COARE_OPT .EQ. 3.0) THEN - !COARE 3.0 (MISLEADING SUBROUTINE NAME) - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ELSE - !COARE 3.5 - CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ENDIF - ENDIF - ELSE - !DEFAULT TO COARE 3.0/3.5 - IF (COARE_OPT .EQ. 3.0) THEN - !COARE 3.0 - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ELSE - !COARE 3.5 - CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) - ENDIF - ENDIF - - ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then - ZNTstoch(I) = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6) - else - ZNTstoch(I) = ZNT(I) - endif - - !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT - ! AHW: Garrattt formula: Calculate roughness Reynolds number - ! Kinematic viscosity of air (linear approx to - ! temp dependence at sea level) - restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1) - - !-------------------------------------- - !CALCULATE z_t and z_q - !-------------------------------------- - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX .EQ. 0 ) THEN - IF (COARE_OPT .EQ. 3.0) THEN - CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) - ELSE - !presumably, this will be published soon, but hasn't yet - CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) - ENDIF - ELSEIF ( ISFTCFLX .EQ. 1 ) THEN - IF (COARE_OPT .EQ. 3.0) THEN - CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) - ELSE - CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) - ENDIF - ELSEIF ( ISFTCFLX .EQ. 2 ) THEN - CALL garratt_1992(z_t(i),z_q(i),ZNTstoch(i),restar,XLAND(I)) - ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - IF (COARE_OPT .EQ. 3.0) THEN - CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) - ELSE - CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) - ENDIF - ELSEIF ( ISFTCFLX .EQ. 4 ) THEN - CALL zilitinkevich_1995(ZNTstoch(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i)) - ENDIF - ELSE - !DEFAULT TO COARE 3.0/3.5 - IF (COARE_OPT .EQ. 3.0) THEN - CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) - ELSE - CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) - ENDIF - ENDIF - - ELSE - - ! add stochastic perturbaction of ZNT - if (spp_pbl==1) then - ZNTstoch(I) = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6) - else - ZNTstoch(I) = ZNT(I) - endif - - !-------------------------------------- - ! LAND - !-------------------------------------- - !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING DEFAULT ZNT - restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1) - - !-------------------------------------- - !GET z_t and z_q - !-------------------------------------- - !CHECK FOR SNOW/ICE POINTS OVER LAND - !IF ( ZNTSTOCH(i) .LE. SNOWZ0 .AND. TSK(I) .LE. 273.15 ) THEN - IF ( SNOWH(i) .GE. 0.1) THEN - CALL Andreas_2002(ZNTSTOCH(i),visc,ust(i),z_t(i),z_q(i)) - ELSE - IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN - !IF IZ0TLND==4, THEN PSIQ WILL BE RECALCULATED USING - !PAN ET AL (1994), but PSIT FROM ZILI WILL BE USED. - CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i)) - ELSEIF ( IZ0TLND .EQ. 2 ) THEN - CALL Yang_2008(ZNTSTOCH(i),z_t(i),z_q(i),UST(i),MOL(I),& - qstar(I),restar,visc,XLAND(I)) - ELSEIF ( IZ0TLND .EQ. 3 ) THEN - !Original MYNN in WRF-ARW used this form: - CALL garratt_1992(z_t(i),z_q(i),ZNTSTOCH(i),restar,XLAND(I)) - ENDIF - ELSE - !DEFAULT TO ZILITINKEVICH - CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,& - UST(I),KARMAN,XLAND(I),0,spp_pbl,rstoch1D(i)) - ENDIF - ENDIF - - ENDIF - zratio(i)=zntstoch(i)/z_t(i) - - !ADD RESISTANCE (SOMEWHAT FOLLOWING JIMENEZ ET AL. (2012)) TO PROTECT AGAINST - !EXCESSIVE FLUXES WHEN USING A LOW FIRST MODEL LEVEL (ZA < 10 m). - !Formerly: GZ1OZ0(I)= LOG(ZA(I)/ZNTstoch(I)) - GZ1OZ0(I)= LOG((ZA(I)+ZNTstoch(I))/ZNTstoch(I)) - GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) - GZ2OZ0(I)= LOG((2.0+ZNTstoch(I))/ZNTstoch(I)) - GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) - GZ10OZ0(I)=LOG((10.+ZNTstoch(I))/ZNTstoch(I)) - GZ10OZt(I)=LOG((10.+z_t(i))/z_t(i)) - - !-------------------------------------------------------------------- - !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS: - ! - ! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.). - ! - ! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: - ! - ! 1. BR .GE. 0.2; - ! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), - ! - ! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; - ! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS - ! (REGIME=2), - ! - ! 3. BR .EQ. 0.0 - ! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), - ! - ! 4. BR .LT. 0.0 - ! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). - ! - !-------------------------------------------------------------------- - IF (BR(I) .GT. 0.0) THEN - IF (BR(I) .GT. 0.2) THEN - !---CLASS 1; STABLE (NIGHTTIME) CONDITIONS: - REGIME(I)=1. - ELSE - !---CLASS 2; DAMPED MECHANICAL TURBULENCE: - REGIME(I)=2. - ENDIF - - !COMPUTE z/L - !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) -! IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) -! ELSE -! ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I)*UST(I),0.0001)) -! ZOL(I)=MAX(ZOL(I),0.0) -! ZOL(I)=MIN(ZOL(I),2.) -! ENDIF - - !COMPUTE PSIM and PSIH - IF((XLAND(I)-1.5).GE.0)THEN - ! WATER - !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) - ELSE - ! LAND - !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) - ENDIF - - ! LOWER LIMIT ON PSI IN STABLE CONDITIONS - PSIM(I)=MAX(PSIM(I),psilim) - PSIH(I)=MAX(PSIH(I),psilim) - PSIM10(I)=MAX(10./ZA(I)*PSIM(I), psilim) - PSIH10(I)=MAX(10./ZA(I)*PSIH(I), psilim) - PSIM2(I)=MAX(2./ZA(I)*PSIM(I), psilim) - PSIH2(I)=MAX(2./ZA(I)*PSIH(I), psilim) - ! 1.0 over Monin-Obukhov length - RMOL(I)= ZOL(I)/ZA(I) - - ELSEIF(BR(I) .EQ. 0.) THEN - !========================================================= - !-----CLASS 3; FORCED CONVECTION/NEUTRAL: - !========================================================= - 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) - - !ZOL(I)=0. - IF(UST(I) .LT. 0.01)THEN - ZOL(I)=BR(I)*GZ1OZ0(I) - ELSE - ZOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(MAX(UST(I)*UST(I),0.001)) - ENDIF - RMOL(I) = ZOL(I)/ZA(I) - - ELSEIF(BR(I) .LT. 0.)THEN - !========================================================== - !-----CLASS 4; FREE CONVECTION: - !========================================================== - REGIME(I)=4. - - !COMPUTE z/L - !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) - !IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN - CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) - !ELSE - ! ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I)*UST(I),0.001)) - ! ZOL(I)=MAX(ZOL(I),-19.999) - ! ZOL(I)=MIN(ZOL(I),0.0) - !ENDIF - - ZOL10=10./ZA(I)*ZOL(I) - ZOL2=2./ZA(I)*ZOL(I) - ZOL(I)=MIN(ZOL(I),0.) - ZOL(I)=MAX(ZOL(I),-19.9999) - ZOL10=MIN(ZOL10,0.) - ZOL10=MAX(ZOL10,-19.9999) - ZOL2=MIN(ZOL2,0.) - ZOL2=MAX(ZOL2,-19.9999) - NZOL=INT(-ZOL(I)*100.) - RZOL=-ZOL(I)*100.-NZOL - NZOL10=INT(-ZOL10*100.) - RZOL10=-ZOL10*100.-NZOL10 - NZOL2=INT(-ZOL2*100.) - RZOL2=-ZOL2*100.-NZOL2 - - !COMPUTE PSIM and PSIH - IF((XLAND(I)-1.5).GE.0)THEN - ! WATER - !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) - !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) - ELSE - ! LAND - !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I)) - !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) - CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) - ENDIF - - PSIM10(I)=10./ZA(I)*PSIM(I) - PSIH10(I)=10./ZA(I)*PSIH(I) - PSIM2(I)=2./ZA(I)*PSIM(I) - PSIH2(I)=2./ZA(I)*PSIH(I) - - !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND - !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES - !---FROM GETTING TOO SMALL - !PSIH(I)=MIN(PSIH(I),0.9*GZ1OZt(I)) !JOE: less restricitive over forest/urban. - PSIH(I)=MIN(PSIH(I),0.9*GZ1OZ0(I)) - PSIM(I)=MIN(PSIM(I),0.9*GZ1OZ0(I)) - !PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZt(I)) !JOE: less restricitive over forest/urban. - PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZ0(I)) - PSIM2(I)=MIN(PSIM2(I),0.9*GZ2OZ0(I)) - PSIM10(I)=MIN(PSIM10(I),0.9*GZ10OZ0(I)) - PSIH10(I)=MIN(PSIH10(I),0.9*GZ10OZ0(I)) - - RMOL(I) = ZOL(I)/ZA(I) - - ENDIF - - !------------------------------------------------------------ - !-----COMPUTE THE FRICTIONAL VELOCITY: - !------------------------------------------------------------ - ! ZA(1982) EQS(2.60),(2.61). - PSIX(I)=GZ1OZ0(I)-PSIM(I) - PSIX10(I)=GZ10OZ0(I)-PSIM10(I) - ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE - OLDUST = UST(I) - UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX(I) - !NON-AVERAGED: UST(I)=KARMAN*WSPD(I)/PSIX(I) - - ! Compute u* without vconv for use in HFX calc when isftcflx > 0 - WSPDI(I)=MAX(SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)), wmin) - IF ( PRESENT(USTM) ) THEN - USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX(I) - ENDIF - - IF ((XLAND(I)-1.5).LT.0.) THEN !LAND - UST(I)=MAX(UST(I),0.005) !Further relaxing this limit - no need to go lower - !Keep ustm = ust over land. - IF ( PRESENT(USTM) ) USTM(I)=UST(I) - ENDIF - - !------------------------------------------------------------ - !-----COMPUTE THE THERMAL AND MOISTURE RESISTANCE (PSIQ AND PSIT): - !------------------------------------------------------------ - ! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL - ! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 - GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) - GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) - - PSIT(I) =MAX(GZ1OZt(I)-PSIH(I) ,1.) - PSIT2(I)=MAX(GZ2OZt(I)-PSIH2(I),1.) - resist(I)=PSIT(I) - logres(I)=GZ1OZt(I) - - PSIQ=MAX(LOG((ZA(I)+z_q(i))/z_q(I))-PSIH(I) ,1.0) - PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,1.0) - - IF((XLAND(I)-1.5).LT.0)THEN !Land only - IF ( IZ0TLND .EQ. 4 ) THEN - CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),& - & KARMAN,ZA(I)) - ENDIF - ENDIF - - !---------------------------------------------------- - !COMPUTE THE TEMPERATURE SCALE (or FRICTION TEMPERATURE, T*) - !---------------------------------------------------- - !DTG=TH1D(I)-THGB(I) !SWITCH TO THETA-V - DTG=THV1D(I)-THVGB(I) - OLDTST=MOL(I) - MOL(I)=KARMAN*DTG/PSIT(I)/PRT - !t_star(I) = -HFX(I)/(UST(I)*CPM(I)*RHO1D(I)) - !t_star(I) = MOL(I) - !---------------------------------------------------- - !COMPUTE THE MOISTURE SCALE (or q*) - DQG=(QVSH(i)-qsfc(i))*1000. !(kg/kg -> g/kg) - qstar(I)=KARMAN*DQG/PSIQ/PRT - - !CHECK FOR CONVERGENCE - IF (ITER .GE. 2) THEN - !IF (ABS(OLDUST-UST(I)) .lt. 0.01) THEN - IF (ABS(OLDTST-MOL(I)) .lt. 0.01) THEN - ITER = ITER+ITMAX - ENDIF - - !IF () THEN - ! print*,"ITER:",ITER - ! write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I)," Tstar:",MOL(I) - ! write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I)," DTHV:",THV1D(I)-THVGB(I) - ! write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) - ! write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I)," za:",za(I) - ! write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",QSFC(I)," QVSH(I):",QVSH(I) - ! print*,"VISC=",VISC," Z0:",ZNTstoch(I)," T1D(i):",T1D(i) - ! write(*,*)"=============================================" - !ENDIF - ENDIF - - ITER = ITER + 1 - - ENDDO ! end ITERATION-loop - - ENDDO ! end i-loop - - 1000 format(A,F6.1, A,f6.1, A,f5.1, A,f7.1) - 1001 format(A,F2.0, A,f10.4,A,f5.3, A,f11.5) - 1002 format(A,f7.2, A,f7.2, A,f7.2, A,f10.3) - 1003 format(A,f7.2, A,f7.2, A,f10.3,A,f10.3) - 1004 format(A,f11.3,A,f9.7, A,f9.7, A,f6.2, A,f10.3) - 1005 format(A,f9.2,A,f6.4,A,f7.4,A,f7.4) - - !---------------------------------------------------------- - ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES - !---------------------------------------------------------- - DO I=its,ite - - !For computing the diagnostics and fluxes (below), whether the fluxes - !are turned off or on, we need the following: - PSIX(I)=GZ1OZ0(I)-PSIM(I) - PSIX10(I)=GZ10OZ0(I)-PSIM10(I) - - PSIT(I) =MAX(GZ1OZt(I)-PSIH(I), 1.0) - PSIT2(I)=MAX(GZ2OZt(I)-PSIH2(I),1.0) - PSIT10=MAX(GZ10OZ0(I)-PSIH10(I), 1.0) - - PSIQ=MAX(LOG((ZA(I)+z_q(i))/z_q(I))-PSIH(I) ,1.0) - PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,1.0) - PSIQ10=MAX(GZ10OZ0(I)-PSIH10(I),1.0) - - IF (ISFFLX .LT. 1) THEN - - QFX(i) = 0. - HFX(i) = 0. - FLHC(I) = 0. - FLQC(I) = 0. - LH(I) = 0. - CHS(I) = 0. - CH(I) = 0. - CHS2(i) = 0. - CQS2(i) = 0. - IF(PRESENT(ck) .and. PRESENT(cd) .and. & - &PRESENT(cka) .and. PRESENT(cda)) THEN - Ck(I) = 0. - Cd(I) = 0. - Cka(I)= 0. - Cda(I)= 0. - ENDIF - ELSE - - IF((XLAND(I)-1.5).LT.0)THEN !LAND Only - IF ( IZ0TLND .EQ. 4 ) THEN - CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),& - & KARMAN,ZA(I)) - ENDIF - ENDIF - - !------------------------------------------ - ! CALCULATE THE EXCHANGE COEFFICIENTS FOR HEAT (FLHC) - ! AND MOISTURE (FLQC) - !------------------------------------------ - FLQC(I)=RHO1D(I)*MAVAIL(I)*UST(I)*KARMAN/PSIQ - FLHC(I)=RHO1D(I)*CPM(I)*UST(I)*KARMAN/PSIT(I) - !OLD WAY: - !DTTHX=ABS(TH1D(I)-THGB(I)) - !IF(DTTHX.GT.1.E-5)THEN - ! FLHC(I)=CPM(I)*RHO1D(I)*UST(I)*MOL(I)/(TH1D(I)-THGB(I)) - !ELSE - ! FLHC(I)=0. - !ENDIF - - !---------------------------------- - ! COMPUTE SURFACE MOISTURE FLUX: - !---------------------------------- - QFX(I)=FLQC(I)*(QSFCMR(I)-QV1D(I)) - !JOE: QFX(I)=MAX(QFX(I),0.) !originally did not allow neg QFX - QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX, like MYJ - LH(I)=XLV*QFX(I) - - !---------------------------------- - ! COMPUTE SURFACE HEAT FLUX: - !---------------------------------- - IF(XLAND(I)-1.5.GT.0.)THEN !WATER - HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN - ! AHW: add dissipative heating term - HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) - ENDIF - ENDIF - ELSEIF(XLAND(I)-1.5.LT.0.)THEN !LAND - HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) - HFX(I)=MAX(HFX(I),-250.) - ENDIF - - !CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & - ! /XKA+ZA(I)/ZL)-PSIH(I)) - - CHS(I)=UST(I)*KARMAN/PSIT(I) - - ! The exchange coefficient for cloud water is assumed to be the - ! same as that for heat. CH is multiplied by WSPD. - - !ch(i)=chs(i) - ch(i)=flhc(i)/( cpm(i)*RHO1D(i) ) - - !THESE ARE USED FOR 2-M DIAGNOSTICS ONLY - CQS2(I)=UST(I)*KARMAN/PSIQ2 - CHS2(I)=UST(I)*KARMAN/PSIT2(I) - - IF(PRESENT(ck) .and. PRESENT(cd) .and. & - &PRESENT(cka) .and. PRESENT(cda)) THEN - Ck(I)=(karman/psix10(I))*(karman/psiq10) - Cd(I)=(karman/psix10(I))*(karman/psix10(I)) - Cka(I)=(karman/psix(I))*(karman/psiq) - Cda(I)=(karman/psix(I))*(karman/psix(I)) - ENDIF - - ENDIF !end ISFFLX option - - !----------------------------------------------------- - !COMPUTE DIAGNOSTICS - !----------------------------------------------------- - !COMPUTE 10 M WNDS - !----------------------------------------------------- - ! If the lowest model level is close to 10-m, use it - ! instead of the flux-based diagnostic formula. - if (ZA(i) .le. 7.0) then - ! high vertical resolution - if(ZA2(i) .gt. 7.0 .and. ZA2(i) .lt. 13.0) then - !use 2nd model level - U10(I)=U1D2(I) - V10(I)=V1D2(I) - else - U10(I)=U1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) - V10(I)=V1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) - endif - elseif(ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then - !moderate vertical resolution - !U10(I)=U1D(I)*PSIX10(I)/PSIX(I) - !V10(I)=V1D(I)*PSIX10(I)/PSIX(I) - !use neutral-log: - U10(I)=U1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) - V10(I)=V1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) - else - ! very coarse vertical resolution - U10(I)=U1D(I)*PSIX10(I)/PSIX(I) - V10(I)=V1D(I)*PSIX10(I)/PSIX(I) - endif - - !----------------------------------------------------- - !COMPUTE 2m T, TH, AND Q - !THESE WILL BE OVERWRITTEN FOR LAND POINTS IN THE LSM - !----------------------------------------------------- - DTG=TH1D(I)-THGB(I) - TH2(I)=THGB(I)+DTG*PSIT2(I)/PSIT(I) - !*** BE CERTAIN THAT THE 2-M THETA IS BRACKETED BY - !*** THE VALUES AT THE SURFACE AND LOWEST MODEL LEVEL. - IF ((TH1D(I)>THGB(I) .AND. (TH2(I)TH1D(I))) .OR. & - (TH1D(I)THGB(I) .OR. TH2(I)QSFCMR(I) .AND. (Q2(I)QV1D(I))) .OR. & - (QV1D(I)QSFCMR(I) .OR. Q2(I) 1200. .OR. HFX(I) < -700.)THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "HFX: ",HFX(I) - yesno = 1 - ENDIF - IF (LH(I) > 1200. .OR. LH(I) < -700.)THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "LH: ",LH(I) - yesno = 1 - ENDIF - IF (UST(I) < 0.0 .OR. UST(I) > 4.0 )THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "UST: ",UST(I) - yesno = 1 - ENDIF - IF (WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0)THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "WSTAR: ",WSTAR(I) - yesno = 1 - ENDIF - IF (RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 )THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "rho: ",RHO1D(I) - yesno = 1 - ENDIF - IF (QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >40.)THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "QSFC: ",QSFC(I) - yesno = 1 - ENDIF - IF (PBLH(I)<0. .OR. PBLH(I)>6000.)THEN - print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& - ITER-ITMAX," ITERATIONS",I,J, "PBLH: ",PBLH(I) - yesno = 1 - ENDIF - - IF (yesno == 1) THEN - print*," OTHER INFO:" - write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),& - " Tstar:",MOL(I) - write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),& - " DTHV:",THV1D(I)-THVGB(I) - write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",& - ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) - write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I),& - " za:",za(I) - write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",& - QSFC(I)," QVSH(I):",QVSH(I) - print*,"PSIX=",PSIX(I)," Z0:",ZNTstoch(I)," T1D(i):",T1D(i) - write(*,*)"=============================================" - ENDIF - ENDIF - - ENDDO !end i-loop - -END SUBROUTINE SFCLAY1D_mynn -!------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns the thermal and moisture roughness lengths -!! from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over -!! land and water, respectively. -!! -!! MODS: -!! 20120705 : added IZ0TLND option. Note: This option was designed -!! to work with the Noah LSM and may be specific for that -!! LSM only. Tests with RUC LSM showed no improvements. - SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& - & landsea,IZ0TLND2,spp_pbl,rstoch) - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea - INTEGER, OPTIONAL, INTENT(IN):: IZ0TLND2 - REAL, INTENT(OUT) :: Zt,Zq - REAL :: CZIL !=0.100 in Chen et al. (1997) - !=0.075 in Zilitinkevich (1995) - !=0.500 in Lemone et al. (2008) - INTEGER, INTENT(IN) :: spp_pbl - REAL, INTENT(IN) :: rstoch - - - IF (landsea-1.5 .GT. 0) THEN !WATER - - !THIS IS BASED ON Zilitinkevich, Grachev, and Fairall (2001; - !Their equations 15 and 16). - IF (restar .LT. 0.1) THEN - Zt = Z_0*EXP(KARMAN*2.0) - Zt = MIN( Zt, 6.0e-5) - Zt = MAX( Zt, 2.0e-9) - Zq = Z_0*EXP(KARMAN*3.0) - Zq = MIN( Zq, 6.0e-5) - Zq = MAX( Zq, 2.0e-9) - ELSE - Zt = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-3.2)) - Zt = MIN( Zt, 6.0e-5) - Zt = MAX( Zt, 2.0e-9) - Zq = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-4.2)) - Zq = MIN( Zt, 6.0e-5) - Zq = MAX( Zt, 2.0e-9) - ENDIF - - ELSE !LAND - - !Option to modify CZIL according to Chen & Zhang, 2009 - IF ( IZ0TLND2 .EQ. 1 ) THEN - CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) ) - ELSE - CZIL = 0.075 !0.10 - END IF - - Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) - Zt = MIN( Zt, Z_0/2.) - - Zq = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) - Zq = MIN( Zq, Z_0/2.) - -! perturb thermal and moisture roughness lenth by +/-50% -! uses same perturbation pattern for perturbing cloud fraction -! and turbulent mixing length (module_sf_mynn.F), but -! twice the amplitude; -! multiplication with -1.0 anticorrelates patterns - if (spp_pbl==1) then - Zt = Zt + Zt * 2.0 * rstoch - Zt = MAX(Zt, 0.001) - Zq = Zt - endif - - ENDIF - - return - - END SUBROUTINE zilitinkevich_1995 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!! This subroutine returns the resistance (PSIQ) for moisture -!! exchange. This is a modified form originating from Pan et al.. -!! (1994) but modified according to tests in both the RUC model. -!! and WRF-ARW. Note that it is very similar to Carlson and -!! Boland (1978) model (include below in comments) but has an -!! extra molecular layer (a third layer) instead of two layers. - SUBROUTINE Pan_etal_1994(PSIQ,PSIQ2,ustar,psih,psih2,KARMAN,Z1) - - IMPLICIT NONE - REAL, INTENT(IN) :: Z1,ustar,KARMAN,psih,psih2 - REAL, INTENT(OUT) :: psiq,psiq2 - REAL, PARAMETER :: Cpan=1.0 !was 20.8 in Pan et al 1994 - REAL, PARAMETER :: ZL=0.01 - REAL, PARAMETER :: ZMUs=0.2E-3 - REAL, PARAMETER :: XKA = 2.4E-5 - - !PAN et al. (1994): 3-layer model, as in paper: - !ZMU = Cpan*XKA/(KARMAN*UST(I)) - !PSIQ =MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & - ! & Z1/ZL) - PSIH,2.0) - !PSIQ2=MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & - ! & 2./ZL) - PSIH2,2.0) - !MODIFIED FORM: - PSIQ =MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*Z1)/XKA + & - & Z1/ZL) - PSIH,2.0) - PSIQ2=MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*2.0)/XKA + & - & 2./ZL) - PSIH2,2.0) - - !CARLSON AND BOLAND (1978): 2-layer model - !PSIQ =MAX(LOG(KARMAN*ustar*Z1/XKA + Z1/ZL)-PSIH ,2.0) - !PSIQ2=MAX(LOG(KARMAN*ustar*2./XKA + 2./ZL)-PSIH2 ,2.0) - - END SUBROUTINE Pan_etal_1994 -!-------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!! This formulation for roughness length was designed to match. -!! the labratory experiments of Donelan et al. (2004). -!! This is an update version from Davis et al. 2008, which -!! corrects a small-bias in Z_0 (AHW real-time 2012). - SUBROUTINE davis_etal_2008(Z_0,ustar) - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar - REAL, INTENT(OUT) :: Z_0 - REAL :: ZW, ZN1, ZN2 - REAL, PARAMETER :: G=9.81, OZO=1.59E-5 - - !OLD FORM: Z_0 = 10.*EXP(-10./(ustar**(1./3.))) - !NEW FORM: - - ZW = MIN((ustar/1.06)**(0.3),1.0) - ZN1 = 0.011*ustar*ustar/G + OZO - ZN2 = 10.*exp(-9.5*ustar**(-.3333)) + & - 0.11*1.5E-5/AMAX1(ustar,0.01) - Z_0 = (1.0-ZW) * ZN1 + ZW * ZN2 - - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE davis_etal_2008 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!>This formulation for roughness length was designed account for. -!!wave steepness. - SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar,wsp10 - REAL, INTENT(OUT) :: Z_0 - REAL, parameter :: g=9.81, pi=3.14159265 - REAL :: hs, Tp, Lp - - !hs is the significant wave height - hs = 0.0248*(wsp10**2.) - !Tp dominant wave period - Tp = 0.729*MAX(wsp10,0.1) - !Lp is the wavelength of the dominant wave - Lp = g*Tp**2/(2*pi) - - Z_0 = 1200.*hs*(hs/Lp)**4.5 - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE Taylor_Yelland_2001 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!>This version of Charnock's relation employs a varying -!! Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. -!! The Charnock parameter CZC is varied from .011 to .018. -!! between 10-m wsp = 10 and 18.. - SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10, zu - REAL, INTENT(OUT) :: Z_0 - REAL, PARAMETER :: G=9.81, CZO2=0.011 - REAL :: CZC !variable charnock "constant" - REAL :: wsp10m ! logarithmically calculated 10 m - - wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) - CZC = CZO2 + 0.007*MIN(MAX((wsp10m-10.)/8., 0.), 1.0) - - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.05)) - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE charnock_1955 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This version of Charnock's relation employs a varying -!!Charnock parameter, taken from COARE 3.5 [Edson et al. (2001, JPO)]. -!!The Charnock parameter CZC is varied from about .005 to .028 -!!between 10-m wind speeds of 6 and 19 m/s. - SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) - - IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10, zu - REAL, INTENT(OUT) :: Z_0 - REAL, PARAMETER :: G=9.81 - REAL, PARAMETER :: m=0.017, b=-0.005 - REAL :: CZC ! variable charnock "constant" - REAL :: wsp10m ! logarithmically calculated 10 m - - wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) - wsp10m = MIN(19., wsp10m) - CZC = m*wsp10m + b - CZC = MAX(CZC, 0.0) - - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.07)) - Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by - Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) - - return - - END SUBROUTINE edson_etal_2013 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This formulation for the thermal and moisture roughness lengths -!! (Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). -!!This formula comes from Fairall et al. (2003). It is modified from -!!the original Garratt-Brutsaert model to better fit the COARE/HEXMAX -!!data. The formula for land uses a constant ratio (Z_0/7.4) taken -!!from Garratt (1992). - SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) - - IMPLICIT NONE - REAL, INTENT(IN) :: Ren, Z_0,landsea - REAL, INTENT(OUT) :: Zt,Zq - REAL :: Rq - REAL, PARAMETER :: e=2.71828183 - - IF (landsea-1.5 .GT. 0) THEN !WATER - - Zt = Z_0*EXP(2.0 - (2.48*(Ren**0.25))) - Zq = Z_0*EXP(2.0 - (2.28*(Ren**0.25))) - - Zq = MIN( Zq, 5.5e-5) - Zq = MAX( Zq, 2.0e-9) - Zt = MIN( Zt, 5.5e-5) - Zt = MAX( Zt, 2.0e-9) !same lower limit as ECMWF - ELSE !LAND - Zq = Z_0/(e**2.) !taken from Garratt (1980,1992) - Zt = Zq - ENDIF - - return - - END SUBROUTINE garratt_1992 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!>This formulation for thermal and moisture roughness length (Zt and Zq) -!! as a function of the roughness Reynolds number (Ren) comes from the -!! COARE3.0 formulation, empirically derived from COARE and HEXMAX data -!! [Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this -!!relationship overestimated the scalar roughness lengths for low Reynolds -!!number flows, so an optional smooth flow relationship, taken from Garratt -!!(1992, p. 102), is available for flows with Ren < 2. -!! -!!This is for use over water only. - SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc) - - IMPLICIT NONE - REAL, INTENT(IN) :: Ren,ustar,visc - REAL, INTENT(OUT) :: Zt,Zq - - IF (Ren .le. 2.) then - - Zt = (5.5e-5)*(Ren**(-0.60)) - Zq = Zt - !FOR SMOOTH SEAS, CAN USE GARRATT - !Zq = 0.2*visc/MAX(ustar,0.1) - !Zq = 0.3*visc/MAX(ustar,0.1) - - ELSE - - !FOR ROUGH SEAS, USE COARE - Zt = (5.5e-5)*(Ren**(-0.60)) - Zq = Zt - - ENDIF - - Zt = MIN(Zt,1.0e-4) - Zt = MAX(Zt,2.0e-9) - - Zq = MIN(Zt,1.0e-4) - Zq = MAX(Zt,2.0e-9) - - return - - END SUBROUTINE fairall_etal_2003 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This formulation for thermal and moisture roughness length (Zt and Zq) -!! as a function of the roughness Reynolds number (Ren) comes from the -!! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data -!! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. -!! This is for use over water only. - SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) - - IMPLICIT NONE - REAL, INTENT(IN) :: Ren,ustar,visc,rstoch - INTEGER, INTENT(IN):: spp_pbl - REAL, INTENT(OUT) :: Zt,Zq - - !Zt = (5.5e-5)*(Ren**(-0.60)) - Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72)) - Zq = Zt - - IF (spp_pbl ==1) THEN - Zt = MAX(Zt + Zt*2.0*rstoch,2.0e-9) - Zq = MAX(Zt + Zt*2.0*rstoch,2.0e-9) - ELSE - Zt = MAX(Zt,2.0e-9) - Zq = MAX(Zt,2.0e-9) - ENDIF - - return - - END SUBROUTINE fairall_etal_2014 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This is a modified version of Yang et al (2002 QJRMS, 2008 JAMC) -!! and Chen et al (2010, J of Hydromet). Although it was originally -!! designed for arid regions with bare soil, it is modified -!! here to perform over a broader spectrum of vegetation. -!! -!!The original formulation relates the thermal roughness length (Zt) -!!to u* and T*: -!! -!! Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar)**0.25)) -!! -!!where ht = Renc*visc/ustar and the critical Reynolds number -!!(Renc) = 70. Beta was originally = 10 (2002 paper) but was revised -!!to 7.2 (in 2008 paper). Their form typically varies the -!!ratio Z0/Zt by a few orders of magnitude (1-1E4). -!! -!!This modified form uses beta = 1.5 and a variable Renc (function of Z_0), -!!so zt generally varies similarly to the Zilitinkevich form (with Czil = 0.1) -!!for very small or negative surface heat fluxes but can become close to the -!!Zilitinkevich with Czil = 0.2 for very large HFX (large negative T*). -!!Also, the exponent (0.25) on tstar was changed to 1.0, since we found -!!Zt was reduced too much for low-moderate positive heat fluxes. -!! -!!This should only be used over land! - SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc,landsea) - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc, landsea - REAL :: ht, &! roughness height at critical Reynolds number - tstar2, &! bounded T*, forced to be non-positive - qstar2, &! bounded q*, forced to be non-positive - Z_02, &! bounded Z_0 for variable Renc2 calc - Renc2 ! variable Renc, function of Z_0 - REAL, INTENT(OUT) :: Zt,Zq - REAL, PARAMETER :: Renc=300., & !old constant Renc - beta=1.5, & !important for diurnal variation - m=170., & !slope for Renc2 function - b=691. !y-intercept for Renc2 function - - Z_02 = MIN(Z_0,0.5) - Z_02 = MAX(Z_02,0.04) - Renc2= b + m*log(Z_02) - ht = Renc2*visc/MAX(ustar,0.01) - tstar2 = MIN(tstar, 0.0) - qstar2 = MIN(qst,0.0) - - Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar2)**1.0)) - Zq = ht * EXP(-beta*(ustar**0.5)*(ABS(qstar2)**1.0)) - !Zq = Zt - - Zt = MIN(Zt, Z_0/2.0) - Zq = MIN(Zq, Z_0/2.0) - - return - - END SUBROUTINE Yang_2008 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This is taken from Andreas (2002; J. of Hydromet) and -!! Andreas et al. (2005; BLM). -!! -!! This should only be used over snow/ice! - SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) - - IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, bvisc, ustar - REAL, INTENT(OUT) :: Zt, Zq - REAL :: Ren2, zntsno - - REAL, PARAMETER :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & - bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & - bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 - - REAL, PARAMETER :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & - bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & - bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - - !Calculate zo for snow (Andreas et al. 2005, BLM) - zntsno = 0.135*bvisc/ustar + & - (0.035*(ustar*ustar)/9.8) * & - (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) - Ren2 = ustar*zntsno/bvisc - - ! Make sure that Re is not outside of the range of validity - ! for using their equations - IF (Ren2 .gt. 1000.) Ren2 = 1000. - - IF (Ren2 .le. 0.135) then - - Zt = zntsno*EXP(bt0_s + bt1_s*LOG(Ren2) + bt2_s*LOG(Ren2)**2) - Zq = zntsno*EXP(bq0_s + bq1_s*LOG(Ren2) + bq2_s*LOG(Ren2)**2) - - ELSE IF (Ren2 .gt. 0.135 .AND. Ren2 .lt. 2.5) then - - Zt = zntsno*EXP(bt0_t + bt1_t*LOG(Ren2) + bt2_t*LOG(Ren2)**2) - Zq = zntsno*EXP(bq0_t + bq1_t*LOG(Ren2) + bq2_t*LOG(Ren2)**2) - - ELSE - - Zt = zntsno*EXP(bt0_r + bt1_r*LOG(Ren2) + bt2_r*LOG(Ren2)**2) - Zq = zntsno*EXP(bq0_r + bq1_r*LOG(Ren2) + bq2_r*LOG(Ren2)**2) - - ENDIF - - return - - END SUBROUTINE Andreas_2002 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns the stability functions based off -!! of Hogstrom (1996). - SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, x0, y, y0, zmL, zhL - - zmL = Z_0*zL/Za - zhL = Zt*zL/Za - - IF (zL .gt. 0.) THEN !STABLE (not well tested - seem large) - - psi_m = -5.3*(zL - zmL) - psi_h = -8.0*(zL - zhL) - - ELSE !UNSTABLE - - x = (1.-19.0*zL)**0.25 - x0= (1.-19.0*zmL)**0.25 - y = (1.-11.6*zL)**0.5 - y0= (1.-11.6*zhL)**0.5 - - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & - &LOG((1.+x**2.)/(1.+x0**2.)) - & - &2.0*ATAN(x) + 2.0*ATAN(x0) - psi_h = 2.*LOG((1.+y)/(1.+y0)) - - ENDIF - - return - - END SUBROUTINE PSI_Hogstrom_1996 -!-------------------------------------------------------------------- -!> \ingroup module_sf_mynn_mod -!> This subroutine returns the stability functions based off -!! of Hogstrom (1996), but with different constants compatible -!! with Dyer and Hicks (1970/74?). This formulation is used for -!! testing/development by Nakanishi (personal communication). - SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL, Zt, Z_0, Za - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, x0, y, y0, zmL, zhL - - zmL = Z_0*zL/Za !Zo/L - zhL = Zt*zL/Za !Zt/L - - IF (zL .gt. 0.) THEN !STABLE - - psi_m = -5.0*(zL - zmL) - psi_h = -5.0*(zL - zhL) - - ELSE !UNSTABLE - - x = (1.-16.*zL)**0.25 - x0= (1.-16.*zmL)**0.25 - - y = (1.-16.*zL)**0.5 - y0= (1.-16.*zhL)**0.5 - - psi_m = 2.*LOG((1.+x)/(1.+x0)) + & - &LOG((1.+x**2.)/(1.+x0**2.)) - & - &2.0*ATAN(x) + 2.0*ATAN(x0) - psi_h = 2.*LOG((1.+y)/(1.+y0)) - - ENDIF - - return - - END SUBROUTINE PSI_DyerHicks -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns the stability functions based off -!! of Beljaar and Holtslag 1991, which is an extension of Holtslag -!! and Debruin 1989. - SUBROUTINE PSI_Beljaars_Holtslag_1991(psi_m, psi_h, zL) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: a=1., b=0.666, c=5., d=0.35 - - IF (zL .lt. 0.) THEN !UNSTABLE - - WRITE(*,*)"WARNING: Universal stability functions from" - WRITE(*,*)" Beljaars and Holtslag (1991) should only" - WRITE(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - ELSE !STABLE - - psi_m = -(a*zL + b*(zL -(c/d))*exp(-d*zL) + (b*c/d)) - psi_h = -((1.+.666*a*zL)**1.5 + & - b*(zL - (c/d))*exp(-d*zL) + (b*c/d) -1.) - - ENDIF - - return - - END SUBROUTINE PSI_Beljaars_Holtslag_1991 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns the stability functions come from -!! Zilitinkevich and Esau (2007, BM), which are formulatioed from the -!! "generalized similarity theory" and tuned to the LES DATABASE64 -!! to determine their dependence on z/L. - SUBROUTINE PSI_Zilitinkevich_Esau_2007(psi_m, psi_h, zL) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: Cm=3.0, Ct=2.5 - - IF (zL .lt. 0.) THEN !UNSTABLE - - WRITE(*,*)"WARNING: Universal stability function from" - WRITE(*,*)" Zilitinkevich and Esau (2007) should only" - WRITE(*,*)" be used in the stable regime!" - psi_m = 0. - psi_h = 0. - - ELSE !STABLE - - psi_m = -Cm*(zL**(5./6.)) - psi_h = -Ct*(zL**(4./5.)) - - ENDIF - - return - - END SUBROUTINE PSI_Zilitinkevich_Esau_2007 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns the flux-profile relationships -!! of Businger el al. 1971. - SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL :: x, y - REAL, PARAMETER :: Pi180 = 3.14159265/180. - - IF (zL .lt. 0.) THEN !UNSTABLE - - x = (1. - 15.0*zL)**0.25 - y = (1. - 9.0*zL)**0.5 - - psi_m = LOG(((1.+x)/2.)**2.) + & - &LOG((1.+x**2.)/2.) - & - &2.0*ATAN(x) + Pi180*90. - psi_h = 2.*LOG((1.+y)/2.) - - ELSE !STABLE - - psi_m = -4.7*zL - psi_h = -(4.7/0.74)*zL - - ENDIF - - return - - END SUBROUTINE PSI_Businger_1971 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!> This subroutine returns flux-profile relatioships based off -!!of Lobocki (1993), which is derived from the MY-level 2 model. -!!Suselj and Sood (2010) applied the surface layer length scales -!!from Nakanishi (2001) to get this new relationship. These functions -!!are more agressive (larger magnitude) than most formulations. They -!!showed improvement over water, but untested over land. - SUBROUTINE PSI_Suselj_Sood_2010(psi_m, psi_h, zL) - - IMPLICIT NONE - REAL, INTENT(IN) :: zL - REAL, INTENT(OUT) :: psi_m, psi_h - REAL, PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 - - IF (zL .gt. 0.) THEN !STABLE - - psi_m = -(zL/Rfc + 1.1223*EXP(1.-1.6666/zL)) - !psi_h = -zL*Ric/((Rfc**2.)*PHIT) + 8.209*(zL**1.1091) - !THEIR EQ FOR PSI_H CRASHES THE MODEL AND DOES NOT MATCH - !THEIR FIG 1. THIS EQ (BELOW) MATCHES THEIR FIG 1 BETTER: - psi_h = -(zL*Ric/((Rfc**2.)*5.) + 7.09*(zL**1.1091)) - - ELSE !UNSTABLE - - psi_m = 0.9904*LOG(1. - 14.264*zL) - psi_h = 1.0103*LOG(1. - 16.3066*zL) - - ENDIF - - return - - END SUBROUTINE PSI_Suselj_Sood_2010 -!-------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!>This subroutine returns a more robust z/L that best matches -!! the z/L from Hogstrom (1996) for unstable conditions and Beljaars -!! and Holtslag (1991) for stable conditions. - SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) - - IMPLICIT NONE - REAL, INTENT(OUT) :: zL - REAL, INTENT(IN) :: Rib, zaz0, z0zt - REAL :: alfa, beta, zaz02, z0zt2 - REAL, PARAMETER :: au11=0.045, bu11=0.003, bu12=0.0059, & - &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & - &bu32=-0.9213, bu33=-0.1057 - REAL, PARAMETER :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& - &aw22=52.50, bw11=-0.0539, bw12=1.540, & - &bw21=-0.669, bw22=-3.282 - REAL, PARAMETER :: as11=0.7529, as21=14.94, bs11=0.1569,& - &bs21=-0.3091, bs22=-1.303 - - !set limits according to Li et al (2010), p 157. - zaz02=zaz0 - IF (zaz0 .lt. 100.0) zaz02=100. - IF (zaz0 .gt. 100000.0) zaz02=100000. - - !set more limits according to Li et al (2010) - z0zt2=z0zt - IF (z0zt .lt. 0.5) z0zt2=0.5 - IF (z0zt .gt. 100.0) z0zt2=100. - - alfa = LOG(zaz02) - beta = LOG(z0zt2) - - IF (Rib .le. 0.0) THEN - zL = au11*alfa*Rib**2 + ( & - & (bu11*beta + bu12)*alfa**2 + & - & (bu21*beta + bu22)*alfa + & - & (bu31*beta**2 + bu32*beta + bu33))*Rib - !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL - zL = MAX(zL,-15.) !LIMITS SET ACCORDING TO Li et al (2010) - zL = MIN(zL,0.) !Figure 1. - ELSEIF (Rib .gt. 0.0 .AND. Rib .le. 0.2) THEN - zL = ((aw11*beta + aw12)*alfa + & - & (aw21*beta + aw22))*Rib**2 + & - & ((bw11*beta + bw12)*alfa + & - & (bw21*beta + bw22))*Rib - !if(zL .LT. 0 .OR. zl .GT. 4)print*,"VIOLATION 00.2:",zL - zL = MIN(zL,20.) !LIMITS ACCORDING TO Li et al (2010), THIER - !FIGUE 1C. - zL = MAX(zL,1.) - ENDIF - - return - - END SUBROUTINE Li_etal_2010 - -!------------------------------------------------------------------- -!>\ingroup module_sf_mynn_mod -!! This subroutine adds pbl modules so they can be optimized in pbl code - SUBROUTINE mym_condensation (kts,kte, & - & dx, dz, & - & thl, qw, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& - & qc_bl1D, cldfra_bl1D, & - & PBLH1,HFX1, & - & Vt, Vq, th, sgm) - -!------------------------------------------------------------------- - - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf - REAL, INTENT(IN) :: dx,PBLH1,HFX1 - REAL, DIMENSION(kts:kte), INTENT(IN) :: dz - REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & - &tsq, qsq, cov, th - - REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm - - REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH - REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D - DOUBLE PRECISION :: t3sq, r3sq, c3sq - - REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& - &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt - INTEGER :: i,j,k - - REAL :: erf - - !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dtl,dqw,dzk - REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el - - !JOE: variables for BL clouds - REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit - REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) - REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds - REAL :: RH_00L, RH_00O, phi_dz, lfac - REAL, PARAMETER :: cdz = 2.0 - REAL, PARAMETER :: mdz = 1.5 - - !JAYMES: variables for tropopause-height estimation - REAL :: theta1, theta2, ht1, ht2 - INTEGER :: k_tropo - - REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 - - k_tropo=5 - - zagl = 0. - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - - DO k = kts,kte-1 - t = th(k)*exner(k) - - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/(p(k)-ep_3*esat) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds - ! at the end of this subroutine. - !Sommeria and Deardorff (1977) scheme, as implemented - !in Nakanishi and Niino (2009), Appendix B - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq - !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl - !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds - !than e-10 - sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - !NORMALIZED DEPARTURE FROM SATURATION - q1(k) = qmq(k) / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - - END DO - - CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/(p(k)-ep_3*esat) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = 0.5*( dz(k) + dz(k-1) ) - end if - dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & - b2 * MAX(Sh(k),0.03))/4. * & - (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) - qmq(k) = qw(k) -qsl - q1(k) = qmq(k) / sgm(k) - cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) - END DO - - CASE (2, -2) - !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS - !JAYMES- this added 27 Apr 2015 - DO k = kts,kte-1 - t = th(k)*exner(k) - !SATURATED VAPOR PRESSURE - esat = esat_blend(t) - !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esat/(p(k)-ep_3*esat) - !dqw/dT: Clausius-Clapeyron - dqsl = qsl*ep_2*ev/( rd*t**2 ) - !RH (0 to 1.0) - RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) - - alp(k) = 1.0/( 1.0+dqsl*xlvcp ) - bet(k) = dqsl*exner(k) - - xl = xl_blend(t) ! obtain latent heat - - tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl - qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio - ! at tl and p - - rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl - ! CB02, Eqn. 4 - - cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 - - a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" - - qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; - ! the numerator of Q1 - - b(k) = a(k)*rsl ! CB02 variable "b" - - dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & - & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) - - dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - - if (k .eq. kts) then - dzk = 0.5*dz(k) - else - dzk = 0.5*( dz(k) + dz(k-1) ) - end if - - cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 - ! in CB02 - zagl = zagl + dz(k) - ls_min = MIN(MAX(zagl,25.),300.) ! Let this be the minimum possible length scale: - ! 25 m < ls_min(=zagl) < 300 m - lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: - ! lfac(750 m) = 4.4 - ! lfac(3 km) = 5.0 - ! lfac(13 km) = 6.0 - - ls = MAX(MIN(lfac*el(k),900.),ls_min) ! Bounded: ls_min < ls < 900 m - ! Note: CB02 use 900 m as a constant free-atmosphere length scale. - ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the - ! MYNN master length scale (el) must exceed 60 m before ls - ! becomes responsive to el, otherwise ls = ls_min = 300 m. - - sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: - & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, - & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, - & +b(k)**2 * cdhdz**2))) ! < 3rd term - ! CB02 use a multiplier of 0.2, but 0.225 is chosen - ! based on tests - - q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation - - cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 - - END DO - END SELECT - - zagl = 0. - RHsum=0. - RHnum=0. - RHmean=0.1 !initialize with small value for small PBLH cases - damp =0 - PBLH2=MAX(10.,PBLH1) - - SELECT CASE(bl_mynn_cloudpdf) - - CASE (-1 : 1) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME - ! OR KUWANO ET AL. - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - !q1=0. - !cld(k)=0. - - !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). - IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN - RHsum=RHsum+RH(k) - RHnum=RHnum+1.0 - RHmean=RHsum/RHnum - ENDIF - RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) - if (HFX1 > HFXmin) then - cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 - else - cld9=0.0 - endif - - edown=PBLH2*.1 - !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX - !(somewhat following results from Zhang and Klein (2013, JAS)) - Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac - if (zagl < PBLH2-edown) then - damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) - elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then - damp=1. - elseif (zagl >= PBLH2+Hshcu)then - damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) - endif - cldfra_bl1D(k)=cld9*damp - !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value - - !use alternate cloud fraction to estimate qc for use in BL clouds-radiation - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 - qc_bl1D(k)=ql(k)*damp - !now recompute estimated lwc for PBL scheme's use - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - eq1 = rrp*EXP( -0.5*q1k*q1k ) - qll = MAX( cld(k)*q1k + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll - - q2p = xlvcp/exner(k) - pt = thl(k) +q2p*ql(k) ! potential temp - - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) - rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt(k) = qt-1.0 -rac*bet(k) - vq(k) = p608*pt-tv0 +rac - - !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, - ! add limit to qc_bl and cldfra_bl: - IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 - IF (CLDFRA_BL1D(k) < 1E-2)THEN - CLDFRA_BL1D(k)=0. - QC_BL1D(k)=0. - ENDIF - - END DO - CASE ( 2, -2) - ! JAYMES- this option added 8 May 2015 - ! The cloud water formulations are taken from CB02, Eq. 8. - ! "fng" represents the non-Gaussian contribution to the liquid - ! water flux; these formulations are from Cuijpers and Bechtold - ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, - ! hereafter BCMT95 - DO k = kts,kte-1 - t = th(k)*exner(k) - q1k = q1(k) - zagl = zagl + dz(k) - IF (q1k < 0.) THEN - ql (k) = sgm(k)*EXP(1.2*q1k-1) - ELSE IF (q1k > 2.) THEN - ql (k) = sgm(k)*q1k - ELSE - ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) - ENDIF - - !Next, adjust our initial estimates of cldfra and ql based - !on tropopause-height and PBLH considerations - !JAYMES: added 4 Nov 2016 - if ((cld(k) .gt. 0.) .or. (ql(k) .gt. 0.)) then - if (k .le. k_tropo) then - !At and below tropopause: impose an upper limit on ql; assume that - !a maximum of 0.5 percent supersaturation in water vapor can be - !available for cloud production - ql_limit = 0.005 * qsat_blend( th(k)*exner(k), p(k) ) - ql(k) = MIN( ql(k), ql_limit ) - else - !Above tropopause: eliminate subgrid clouds from CB scheme - cld(k) = 0. - ql(k) = 0. - endif - endif - - !Buoyancy-flux-related calculations follow... - ! "Fng" represents the non-Gaussian transport factor - ! (non-dimensional) from from Bechtold et al. 1995 - ! (hereafter BCMT95), section 3(c). Their suggested - ! forms for Fng (from their Eq. 20) are: - ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 - Fng = 1. - - xl = xl_blend(t) - bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from - ! "b" in CB02 (i.e., b(k) above) by a factor - ! of T/theta. Strictly, b(k) above is formulated in - ! terms of sat. mixing ratio, but bb in BCMT95 is - ! cast in terms of sat. specific humidity. The - ! conversion is neglected here. - qww = 1.+0.61*qw(k) - alpha = 0.61*th(k) - beta = (th(k)/t)*(xl/cp) - 1.61*th(k) - - vt(k) = qww - cld(k)*beta*bb*Fng - 1. - vq(k) = alpha + cld(k)*beta*a(k)*Fng - tv0 - ! vt and vq correspond to beta-theta and beta-q, respectively, - ! in NN09, Eq. B8. They also correspond to the bracketed - ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng - ! The "-1" and "-tv0" terms are included for consistency with - ! the legacy vt and vq formulations (above). - - ! increase the cloud fraction estimate below PBLH+1km - if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.8*cld(k) ) - ! return a cloud condensate and cloud fraction for icloud_bl option: - cldfra_bl1D(k) = cld(k) - qc_bl1D(k) = ql(k) - - !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, - ! add limit to qc_bl and cldfra_bl: - IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 - IF (CLDFRA_BL1D(k) < 1E-2)THEN - CLDFRA_BL1D(k)=0. - QC_BL1D(k)=0. - ENDIF - - END DO - - END SELECT !end cloudPDF option - - !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. - IF (bl_mynn_cloudpdf .LT. 0) THEN - DO k = kts,kte-1 - cldfra_bl1D(k) = 0.0 - qc_bl1D(k) = 0.0 - END DO - ENDIF - - cld(kte) = cld(kte-1) - ql(kte) = ql(kte-1) - vt(kte) = vt(kte-1) - vq(kte) = vq(kte-1) - qc_bl1D(kte)=0. - cldfra_bl1D(kte)=0. - - RETURN - - END SUBROUTINE mym_condensation - -! ================================================================== - - -END MODULE module_sf_mynn - diff --git a/physics/moninshoc.f b/physics/moninshoc.f deleted file mode 100644 index 05473db6c..000000000 --- a/physics/moninshoc.f +++ /dev/null @@ -1,607 +0,0 @@ -!> \file moninshoc.f -!! Contains most of the SHOC PBL/shallow convection scheme. - -!> This module contains the CCPP-compliant SHOC scheme. - module moninshoc - - contains - - subroutine moninshoc_init () - end subroutine moninshoc_init - - subroutine moninshoc_finalize () - end subroutine moninshoc_finalize - -!!!!! ========================================================== !!!!! -! subroutine 'moninshoc' computes pbl height and applies vertical diffusion -! using the coefficient provided by the SHOC scheme (from previous step) -! 2015-05-04 - Shrinivas Moorthi - original version based on monin -! 2018-03-21 - Shrinivas Moorthi - fixed a bug related to tke vertical diffusion -! and gneralized the tke location in tracer array -! 2018-03-23 - Shrinivas Moorthi - used twice the momentum diffusion coefficient -! for tke as in Deardorff (1980) - added tridi1 -! -!> \section arg_table_moninshoc_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | -!! | ncnd | number_of_tracers_for_cloud_condensate | number of tracers for cloud condensate | count | 0 | integer | | in | F | -!! | dv | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | du | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | tau | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | rtg | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | -!! | u1 | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | v1 | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | t1 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | q1 | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | -!! | tkh | atmosphere_heat_diffusivity_from_shoc | diffusivity for heat from the SHOC scheme | m2 s-1 | 2 | real | kind_phys | in | F | -!! | prnum | prandtl_number | turbulent Prandtl number | none | 2 | real | kind_phys | inout | F | -!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | -!! | psk | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at the surface interface | none | 1 | real | kind_phys | in | F | -!! | rbsoil | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | -!! | u10m | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | v10m | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | fm | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | -!! | fh | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | -!! | tsea | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | -!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | -!! | spd1 | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | -!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | del | air_pressure_difference_between_midlayers | pres(k) - pres(k+1) | Pa | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prslk | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | -!! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dkt | atmosphere_heat_diffusivity | diffusivity for heat | m2 s-1 | 2 | real | kind_phys | out | F | -!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | -!! | kinver | index_of_highest_temperature_inversion | index of highest temperature inversion | index | 1 | integer | | in | F | -!! | xkzm_m | atmosphere_momentum_diffusivity_background | background value of momentum diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_h | atmosphere_heat_diffusivity_background | background value of heat diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_s | diffusivity_background_sigma_level | sigma level threshold for background diffusivity | none | 0 | real | kind_phys | in | F | -!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | -!! | ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | grav | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | -!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! - subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, - & u1,v1,t1,q1,tkh,prnum,ntke, - & psk,rbsoil,zorl,u10m,v10m,fm,fh, - & tsea,heat,evap,stress,spd1,kpbl, - & prsi,del,prsl,prslk,phii,phil,delt, - & dusfc,dvsfc,dtsfc,dqsfc,dkt,hpbl, - & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr,me, - & grav, rd, cp, hvap, fv, - & errmsg,errflg) -! - use machine , only : kind_phys - use funcphys , only : fpvs - - implicit none -! -! arguments -! - logical, intent(in) :: lprnt - integer, intent(in) :: ix, im, - & km, ntrac, ntcw, ncnd, ntke, ipr, me - integer, dimension(im), intent(in) :: kinver - - real(kind=kind_phys), intent(in) :: delt, - & xkzm_m, xkzm_h, xkzm_s - real(kind=kind_phys), intent(in) :: grav, - & rd, cp, hvap, fv - real(kind=kind_phys), dimension(im), intent(in) :: psk, - & rbsoil, zorl, u10m, v10m, fm, fh, tsea, heat, evap, stress, spd1 - real(kind=kind_phys), dimension(ix,km), intent(in) :: u1, v1, - & t1, tkh, del, prsl, phil, prslk - real(kind=kind_phys), dimension(ix,km+1), intent(in) :: prsi, phii - real(kind=kind_phys), dimension(ix,km,ntrac), intent(in) :: q1 - - real(kind=kind_phys), dimension(im,km), intent(inout) :: du, dv, - & tau, prnum - real(kind=kind_phys), dimension(im,km,ntrac), intent(inout) :: rtg - - integer, dimension(im), intent(out) :: kpbl - real(kind=kind_phys), dimension(im), intent(out) :: dusfc, - & dvsfc, dtsfc, dqsfc, hpbl - real(kind=kind_phys), dimension(im,km-1), intent(out) :: dkt - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -! locals -! - integer i,is,k,kk,km1,kmpbl,kp1, ntloc -! - logical pblflg(im), sfcflg(im), flg(im) - - real(kind=kind_phys), dimension(im) :: phih, phim - &, rbdn, rbup, sflux, z0, crb, zol, thermal - &, beta, tx1 -! - real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad - &, dt2odel - real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au - &, dku, rdzt -! - real(kind=kind_phys) zi(im,km+1), a2(im,km*(ntrac+1)) -! - real(kind=kind_phys) dsdz2, dsdzq, dsdzt, dsig, dt2, rdt - &, dtodsd, dtodsu, rdz, tem, tem1 - &, ttend, utend, vtend, qtend - &, spdk2, rbint, ri, zol1, robn, bvf2 -! - real(kind=kind_phys), parameter :: zolcr=0.2, - & zolcru=-0.5, rimin=-100., sfcfrac=0.1, - & crbcon=0.25, crbmin=0.15, crbmax=0.35, - & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, - & aphi5=5., aphi16=16., f0=1.e-4 - &, dkmin=0.0, dkmax=1000. -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, prmin=0.25, prmax=4.0 - &, vk=0.4, cfac=6.5 - real(kind=kind_phys) :: gravi, cont, conq, conw, gocp - - gravi = 1.0/grav - cont = cp/grav - conq = hvap/grav - conw = 1.0/grav - gocp = grav/cp - -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! -!----------------------------------------------------------------------- -! -! compute preliminary variables -! - if (ix < im) stop -! -! if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) - dt2 = delt - rdt = 1. / dt2 - km1 = km - 1 - kmpbl = km / 2 -! - do k=1,km - do i=1,im - zi(i,k) = phii(i,k) * gravi - zl(i,k) = phil(i,k) * gravi - dt2odel(i,k) = dt2 / del(i,k) - enddo - enddo - do i=1,im - zi(i,km+1) = phii(i,km+1) * gravi - enddo -! - do k = 1,km1 - do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - prnum(i,k) = 1.0 - enddo - enddo -! Setup backgrond diffision - do i=1,im - prnum(i,km) = 1.0 - tx1(i) = 1.0 / prsi(i,1) - enddo - do k = 1,km1 - do i=1,im - xkzo(i,k) = 0.0 - xkzmo(i,k) = 0.0 - if (k < kinver(i)) then -! vertical background diffusivity for heat and momentum - tem1 = 1.0 - prsi(i,k+1) * tx1(i) - tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) - xkzo(i,k) = xkzm_h * tem1 - xkzmo(i,k) = xkzm_m * tem1 - endif - enddo - enddo -! if (lprnt) then -! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) -! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) -! endif -! -! diffusivity in the inversion layer is set to be xkzminv (m^2/s) -! -! do k = 1,kmpbl -! do i=1,im -! if(zi(i,k+1) > 250.) then -! tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) -! if(tem1 > 1.e-5) then -! xkzo(i,k) = min(xkzo(i,k),xkzminv) -! endif -! endif -! enddo -! enddo -! -! - do i = 1,im - z0(i) = 0.01 * zorl(i) - kpbl(i) = 1 - hpbl(i) = zi(i,1) - pblflg(i) = .true. - sfcflg(i) = .true. - if(rbsoil(i) > 0.) sfcflg(i) = .false. - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do k = 1,km - do i=1,im - tx1(i) = 0.0 - enddo - do kk=1,ncnd - do i=1,im - tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin) - enddo - enddo - do i = 1,im - theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-tx1(i)) - enddo - enddo -! -! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) - do i = 1,im - sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. - beta(i) = dt2 / (zi(i,2)-zi(i,1)) - enddo -! -! compute the pbl height -! -! write(0,*)' IN moninbl u10=',u10m(1:5),' v10=',v10m(1:5) - do i=1,im - flg(i) = .false. - rbup(i) = rbsoil(i) -! - if(pblflg(i)) then - thermal(i) = thvx(i,1) - crb(i) = crbcon - else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = max(1.0, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) - robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = max(min(0.16 * (tem1 ** (-0.18)), crbmax), crbmin) - endif - enddo - do k = 1, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) - rbup(i) = (thvx(i,k)-thermal(i))*phil(i,k) - & / (thvx(i,1)*spdk2) - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo - do i = 1,im - if(kpbl(i) > 1) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) - endif - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - else - hpbl(i) = zl(i,1) - kpbl(i) = 1 - endif - enddo -! -! compute similarity parameters -! - do i=1,im - zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - if(sfcflg(i)) then - zol(i) = min(zol(i),-zfmin) - else - zol(i) = max(zol(i),zfmin) - endif - zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) - if(sfcflg(i)) then -! phim(i) = (1.-aphi16*zol1)**(-1./4.) -! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = 1.0 / max(1. - aphi16*zol1, 1.0e-8) - phih(i) = sqrt(tem) - phim(i) = sqrt(phih(i)) - else - phim(i) = 1. + aphi5*zol1 - phih(i) = phim(i) - endif - enddo -! -! enhance the pbl height by considering the thermal excess -! - do i=1,im - flg(i) = .true. - if (pblflg(i)) then - flg(i) = .false. - rbup(i) = rbsoil(i) - endif - enddo - do k = 2, kmpbl - do i = 1, im - if(.not.flg(i)) then - rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) - rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k) - & / (thvx(i,1)*spdk2) - kpbl(i) = k - flg(i) = rbup(i) > crb(i) - endif - enddo - enddo - do i = 1,im - if (pblflg(i)) then - k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. - elseif(rbup(i) <= crb(i)) then - rbint = 1. - else - rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) - endif - if (k > 1) then - hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) - if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 - if(kpbl(i) <= 1) then - pblflg(i) = .false. - endif - else - pblflg(i) = .false. - endif - endif - if (pblflg(i)) then - tem = phih(i)/phim(i) + cfac*vk*sfcfrac - else - tem = phih(i)/phim(i) - endif - prnum(i,1) = min(prmin,max(prmax,tem)) - enddo -! - do i = 1, im - if(zol(i) > zolcr) then - kpbl(i) = 1 - endif - enddo -! -! compute Prandtl number above boundary layer -! - do k = 1, km1 - kp1 = k + 1 - do i=1,im - if(k >= kpbl(i)) then - rdz = rdzt(i,k) - tem = u1(i,k) - u1(i,kp1) - tem1 = v1(i,k) - v1(i,kp1) - tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,kp1)) - ri = max(bvf2/tem,rimin) - if(ri < 0.) then ! unstable regime - prnum(i,kp1) = 1.0 - else - prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) - endif - elseif (k > 1) then - prnum(i,kp1) = prnum(i,1) - endif -! -! prnum(i,kp1) = 1.0 - prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) - tem = tkh(i,kp1) * prnum(i,kp1) - dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) - dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k)) - enddo - enddo -! -! compute tridiagonal matrix elements for heat and moisture -! - do i=1,im - ad(i,1) = 1. - a1(i,1) = t1(i,1) + beta(i) * heat(i) - a2(i,1) = q1(i,1,1) + beta(i) * evap(i) - enddo -! if (lprnt) write(0,*)' a1=',a1(ipr,1),' beta=',beta(ipr) -! &,' heat=',heat(ipr), ' t1=',t1(ipr,1) - - ntloc = 1 - if(ntrac > 1) then - is = 0 - do k = 2, ntrac - if (k /= ntke) then - ntloc = ntloc + 1 - is = is + km - do i = 1, im - a2(i,1+is) = q1(i,1,k) - enddo - endif - enddo - endif -! - do k = 1,km1 - kp1 = k + 1 - do i = 1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - rdz = rdzt(i,k) - tem1 = dsig * dkt(i,k) * rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - ad(i,k) = ad(i,k)-au(i,k) - ad(i,kp1) = 1.-al(i,k) - dsdzt = tem1 * gocp - a1(i,k) = a1(i,k) + dtodsd*dsdzt - a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt - a2(i,kp1) = q1(i,kp1,1) -! - enddo - enddo -! - if(ntrac > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + km - do k = 1, km1 - kp1 = k + 1 - do i = 1, im - a2(i,kp1+is) = q1(i,kp1,kk) - enddo - enddo - endif - enddo - endif -! -! solve tridiagonal problem for heat and moisture -! - call tridin(im,km,ntloc,al,ad,au,a1,a2,au,a1,a2) - -! -! recover tendencies of heat and moisture -! - do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k)) * rdt - qtend = (a2(i,k)-q1(i,k,1)) * rdt - tau(i,k) = tau(i,k) + ttend -! if(lprnt .and. i==ipr .and. k<11) write(0,*)' tau=',tau(ipr,k) -! &,' ttend=',ttend,' a1=',a1(ipr,k),' t1=',t1(ipr,k) - rtg(i,k,1) = rtg(i,k,1) + qtend - dtsfc(i) = dtsfc(i) + cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i) + conq*del(i,k)*qtend - enddo - enddo - if(ntrac > 1) then - is = 0 - do kk = 2, ntrac - if (kk /= ntke) then - is = is + km - do k = 1, km - do i = 1, im - qtend = (a2(i,k+is)-q1(i,k,kk))*rdt - rtg(i,k,kk) = rtg(i,k,kk) + qtend - enddo - enddo - endif - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) - a1(i,1) = u1(i,1) - a2(i,1) = v1(i,1) - enddo -! - do k = 1,km1 - kp1 = k + 1 - do i=1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - rdz = rdzt(i,k) - tem1 = dsig*dku(i,k)*rdz - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) - a1(i,kp1) = u1(i,kp1) - a2(i,kp1) = v1(i,kp1) -! - enddo - enddo - - call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) -! -! recover tendencies of momentum -! - do k = 1,km - do i = 1,im - utend = (a1(i,k)-u1(i,k))*rdt - vtend = (a2(i,k)-v1(i,k))*rdt - du(i,k) = du(i,k) + utend - dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend - enddo - enddo -! - if (ntke > 0) then ! solve tridiagonal problem for momentum and tke -! -! compute tridiagonal matrix elements for tke -! - do i=1,im - ad(i,1) = 1.0 - a1(i,1) = q1(i,1,ntke) - enddo -! - do k = 1,km1 - kp1 = k + 1 - do i=1,im - dtodsd = dt2odel(i,k) - dtodsu = dt2odel(i,kp1) - dsig = prsl(i,k)-prsl(i,kp1) - rdz = rdzt(i,k) - tem1 = dsig*dku(i,k)*(rdz+rdz) - dsdz2 = tem1 * rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! - ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) - a1(i,kp1) = q1(i,kp1,ntke) - enddo - enddo - - call tridi1(im,km,al,ad,au,a1,au,a1) -! - do k = 1, km ! recover tendencies of tke - do i = 1, im - qtend = (a1(i,k)-q1(i,k,ntke))*rdt - rtg(i,k,ntke) = rtg(i,k,ntke) + qtend - enddo - enddo - endif -! - return - end subroutine moninshoc_run - - end module moninshoc diff --git a/physics/ozphys.f b/physics/ozphys.f deleted file mode 100644 index 4acf87107..000000000 --- a/physics/ozphys.f +++ /dev/null @@ -1,202 +0,0 @@ -!> \file ozphys.f -!! This file is ozone sources and sinks (previous version). - - -!> This module contains the CCPP-compliant Ozone photochemistry scheme. - module ozphys - - contains - -! \brief Brief description of the subroutine -! -!> \section arg_table_ozphys_init Argument Table -!! - subroutine ozphys_init() - end subroutine ozphys_init - -! \brief Brief description of the subroutine -! -!> \section arg_table_ozphys_finalize Argument Table -!! - subroutine ozphys_finalize() - end subroutine ozphys_finalize - - -!>\defgroup GFS_ozphys GFS ozphys Main -!! \brief The operational GFS currently parameterizes ozone production and -!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval -!! Research Laboratory through CHEM2D chemistry model -!! (McCormack et al. (2006) \cite mccormack_et_al_2006). -!! \section arg_table_ozphys_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|---------------------------------------------------------------------------|----------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | -!! | ko3 | vertical_dimension_of_ozone_forcing_data | number of vertical layers in ozone forcing data | count | 0 | integer | | in | F | -!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | oz | ozone_concentration_updated_by_physics | ozone concentration updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | tin | air_temperature_updated_by_physics | updated air temperature | K | 2 | real | kind_phys | in | F | -!! | po3 | natural_log_of_ozone_forcing_data_pressure_levels | natural log of ozone forcing data pressure levels | log(Pa) | 1 | real | kind_phys | in | F | -!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prdout | ozone_forcing | ozone forcing coefficients | various | 3 | real | kind_phys | in | F | -!! | oz_coeff | number_of_coefficients_in_ozone_forcing_data | number of coefficients in ozone forcing data | index | 0 | integer | | in | F | -!! | delp | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | -!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | -!! | ozp1 | cumulative_change_in_ozone_concentration_due_to_production_and_loss_rate | cumulative change in ozone concentration due to production and loss rate | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | ozp2 | cumulative_change_in_ozone_concentration_due_to_ozone_mixing_ratio | cumulative change in ozone concentration due to ozone mixing ratio | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | ozp3 | cumulative_change_in_ozone_concentration_due_to_temperature | cumulative change in ozone concentration due to temperature | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | ozp4 | cumulative_change_in_ozone_concentration_due_to_overhead_ozone_column | cumulative change in ozone concentration due to overhead ozone column | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!> \section genal_ozphys GFS ozphys_run General Algorithm -!> @{ - subroutine ozphys_run ( & - & ix, im, levs, ko3, dt, oz, tin, po3, & - & prsl, prdout, oz_coeff, delp, ldiag3d, & - & ozp1, ozp2, ozp3, ozp4, con_g, me, errmsg, errflg) -! -! this code assumes that both prsl and po3 are from bottom to top -! as are all other variables -! - use machine , only : kind_phys - implicit none -! - ! Interface variables - integer, intent(in) :: im, ix, levs, ko3, oz_coeff, me - real(kind=kind_phys), intent(inout) :: & - & oz(ix,levs) - ! These arrays may not be allocated and need assumed array sizes - real(kind=kind_phys), intent(inout) :: & - & ozp1(:,:), ozp2(:,:), ozp3(:,:), ozp4(:,:) - real(kind=kind_phys), intent(in) :: & - & dt, po3(ko3), prdout(ix,ko3,oz_coeff), & - & prsl(ix,levs), tin(ix,levs), delp(ix,levs), & - & con_g - real :: gravi - logical, intent(in) :: ldiag3d - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! - ! Local variables - integer k,kmax,kmin,l,i,j - logical flg(im) - real(kind=kind_phys) pmax, pmin, tem, temp - real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff), - & ozib(im), colo3(im,levs+1), ozi(ix,levs) -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! -! save input oz in ozi - ozi = oz - gravi=1.0/con_g -! -!> - Calculate vertical integrated column ozone values. - if (oz_coeff > 2) then - colo3(:,levs+1) = 0.0 - do l=levs,1,-1 - do i=1,im - colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi - enddo - enddo - endif -! -!> - Apply vertically linear interpolation to the ozone coefficients. - do l=1,levs - pmin = 1.0e10 - pmax = -1.0e10 -! - do i=1,im - wk1(i) = log(prsl(i,l)) - pmin = min(wk1(i), pmin) - pmax = max(wk1(i), pmax) - prod(i,:) = 0.0 - enddo - kmax = 1 - kmin = 1 - do k=1,ko3-1 - if (pmin < po3(k)) kmax = k - if (pmax < po3(k)) kmin = k - enddo -! - do k=kmin,kmax - temp = 1.0 / (po3(k) - po3(k+1)) - do i=1,im - flg(i) = .false. - if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then - flg(i) = .true. - wk2(i) = (wk1(i) - po3(k+1)) * temp - wk3(i) = 1.0 - wk2(i) - endif - enddo - do j=1,oz_coeff - do i=1,im - if (flg(i)) then - prod(i,j) = wk2(i) * prdout(i,k,j) - & + wk3(i) * prdout(i,k+1,j) - endif - enddo - enddo - enddo -! - do j=1,oz_coeff - do i=1,im - if (wk1(i) < po3(ko3)) then - prod(i,j) = prdout(i,ko3,j) - endif - if (wk1(i) >= po3(1)) then - prod(i,j) = prdout(i,1,j) - endif - enddo - enddo - - if (oz_coeff == 2) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) - enddo -! - !if (ldiag3d) then ! ozone change diagnostics - ! do i=1,im - ! ozp1(i,l) = ozp1(i,l) + prod(i,1)*dt - ! ozp2(i,l) = ozp2(i,l) + (oz(i,l) - ozib(i)) - ! enddo - !endif - endif -!> - Calculate the 4 terms of prognostic ozone change during time \a dt: -!! - ozp1(:,:) - Ozone production from production/loss ratio -!! - ozp2(:,:) - Ozone production from ozone mixing ratio -!! - ozp3(:,:) - Ozone production from temperature term at model layers -!! - ozp4(:,:) - Ozone production from column ozone term at model layers - if (oz_coeff == 4) then - do i=1,im - ozib(i) = ozi(i,l) ! no filling - tem = prod(i,1) + prod(i,3)*tin(i,l) - & + prod(i,4)*colo3(i,l+1) -! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) -! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) - oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt) - enddo - !if (ldiag3d) then ! ozone change diagnostics - ! do i=1,im - ! ozp1(i,l) = ozp1(i,l) + prod(i,1)*dt - ! ozp2(i,l) = ozp2(i,l) + (oz(i,l) - ozib(i)) - ! ozp3(i,l) = ozp3(i,l) + prod(i,3)*tin(i,l)*dt - ! ozp4(i,l) = ozp4(i,l) + prod(i,4)*colo3(i,l+1)*dt - ! enddo - !endif - endif - - enddo ! vertical loop -! - return - end subroutine ozphys_run -!> @} - - end module ozphys diff --git a/physics/precpd.f b/physics/precpd.f deleted file mode 100644 index 9e8f5b696..000000000 --- a/physics/precpd.f +++ /dev/null @@ -1,735 +0,0 @@ -!> \file precpd.f -!! This file contains the subroutine that calculates precipitation -!! processes from suspended cloud water/ice. - -!> This module contains the CCPP-compliant zhao_carr_precpd scheme. - module zhaocarr_precpd - contains - -!! \brief Brief description of the subroutine -!! -!! \section arg_table_zhaocarr_precpd_init Argument Table -!! - subroutine zhaocarr_precpd_init () - end subroutine zhaocarr_precpd_init - -!> \defgroup precip GFS precpd Main -!! \brief This subroutine computes the conversion from condensation to -!! precipitation (snow or rain) or evaporation of rain. -!! -!! \section arg_table_zhaocarr_precpd_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|---------------------------------------------------------------|-------------------------------------------------------------------|-------------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | del | air_pressure_difference_between_midlayers | pressure level thickness | Pa | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | -!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | cwm | cloud_condensed_water_mixing_ratio_updated_by_physics | moist cloud condensed water mixing ratio | kg kg-1 | 2 | real | kind_phys | inout | F | -!! | t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | inout | F | -!! | rn | lwe_thickness_of_explicit_precipitation_amount | explicit precipitation amount on physics timestep | m | 1 | real | kind_phys | out | F | -!! | sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | frac | 1 | real | kind_phys | out | F | -!! | rainp | tendency_of_rain_water_mixing_ratio_due_to_microphysics | tendency of rain water mixing ratio due to microphysics | kg kg-1 s-1 | 2 | real | kind_phys | out | F | -!! | u00k | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | -!! | psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | none | 1 | real | kind_phys | in | F | -!! | prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | none | 1 | real | kind_phys | in | F | -!! | evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | none | 0 | real | kind_phys | in | F | -!! | wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | none | 1 | real | kind_phys | in | F | -!! | wk1 | grid_size_related_coefficient_used_in_scale-sensitive_schemes | grid size related coefficient used in scale-sensitive schemes | none | 1 | real | kind_phys | in | F | -!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | -!! | jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!> \section general_precpd GFS precpd Scheme General Algorithm -!! The following two equations can be used to calculate the -!! precipitation rates of rain and snow at each model level: -!!\f[ -!! P_{r}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{raut}+P_{racw}+P_{sacw}+P_{sm1}+P_{sm2}-E_{rr})d\eta -!! \f] -!! and -!! \f[ -!! P_{s}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{saut}+P_{saci}-P_{sm1}-P_{sm2}-E_{rs})d\eta -!! \f] -!! where \f$p_{s}\f$ and\f$p_{t}\f$ are the surface pressure and the -!! pressure at the top of model domain, respectively, and \f$g\f$ is -!! gravity. The implementation of the precipitation scheme also -!! includes a simplified procedure of computing \f$P_{r}\f$ -!! and \f$P_{s}\f$ (Zhao and Carr (1997) \cite zhao_and_carr_1997). -!! -!! The calculation is as follows: -!! -# Calculate precipitation production by auto conversion and accretion (\f$P_{saut}\f$, \f$P_{saci}\f$, \f$P_{raut}\f$). -!! - The accretion of cloud water by rain, \f$P_{racw}\f$, is not included in the current operational scheme. -!! -# Calculate evaporation of precipitation (\f$E_{rr}\f$ and \f$E_{rs}\f$). -!! -# Calculate melting of snow (\f$P_{sm1}\f$ and \f$P_{sm2}\f$, \f$P_{sacw}\f$). -!! -# Update t and q due to precipitation (snow or rain) production. -!! -# Calculate precipitation at surface (\f$rn\f$) and fraction of frozen precipitation (\f$sr\f$). -!! \section Zhao-Carr_precip_detailed GFS precpd Scheme Detailed Algorithm -!> @{ - subroutine zhaocarr_precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn & - &, sr,rainp,u00k,psautco,prautco,evpco,wminco & - &, wk1,lprnt,jpr,errmsg,errflg) - -! -! ****************************************************************** -! * * -! * subroutine for precipitation processes * -! * from suspended cloud water/ice * -! * * -! ****************************************************************** -! * * -! * originally created by q. zhao jan. 1995 * -! * ------- * -! * modified and rewritten by shrinivas moorthi oct. 1998 * -! * ----------------- * -! * and hua-lu pan * -! * ---------- * -! * * -! * references: * -! * * -! * zhao and carr (1997), monthly weather review (august) * -! * sundqvist et al., (1989) monthly weather review. (august) * -! * chuang 2013, modify sr to define frozen precipitation fraction* -! ****************************************************************** -! -! in this code vertical indexing runs from surface to top of the -! model -! -! argument list: -! -------------- -! im : inner dimension over which calculation is made -! ix : maximum inner dimension -! km : number of vertical levels -! dt : time step in seconds -! del(km) : pressure layer thickness (bottom to top) -! prsl(km) : pressure values for model layers (bottom to top) -! q(ix,km) : specific humidity (updated in the code) -! cwm(ix,km) : condensate mixing ratio (updated in the code) -! t(ix,km) : temperature (updated in the code) -! rn(im) : precipitation over one time-step dt (m/dt) -!old sr(im) : index (=-1 snow, =0 rain/snow, =1 rain) -!new sr(im) : "snow ratio", ratio of snow to total precipitation -! cll(ix,km) : cloud cover -!hchuang rn(im) unit in m per time step -! precipitation rate conversion 1 mm/s = 1 kg/m2/s -! - use machine , only : kind_phys - use funcphys , only : fpvs - use physcons, grav => con_g, hvap => con_hvap, hfus => con_hfus - &, ttp => con_ttp, cp => con_cp - &, eps => con_eps, epsm1 => con_epsm1 - implicit none -! include 'constant.h' -! -! Interface variables - integer, intent(in) :: im, ix, km, jpr - real (kind=kind_phys), intent(in) :: dt - real (kind=kind_phys), intent(in) :: del(ix,km), prsl(ix,km) - real (kind=kind_phys), intent(inout) :: q(ix,km), t(ix,km), & - & cwm(ix,km) - real (kind=kind_phys), intent(out) :: rn(im), sr(im), rainp(im,km) - real (kind=kind_phys), intent(in) :: u00k(im,km) - real (kind=kind_phys), intent(in) :: psautco(2), prautco(2), & - & evpco, wminco(2), wk1(im) - logical, intent(in) :: lprnt - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -! Local variables - real (kind=kind_phys) g, h1, h1000 - &, d00 - &, elwv, eliv, row - &, epsq, eliw - &, rcp, rrow - parameter (g=grav, h1=1.e0, h1000=1000.0 - &, d00=0.e0 - &, elwv=hvap, eliv=hvap+hfus, row=1.e3 - &, epsq=2.e-12 - &, eliw=eliv-elwv, rcp=h1/cp, rrow=h1/row) -! - real(kind=kind_phys), parameter :: cons_0=0.0, cons_p01=0.01 - &, cons_20=20.0 - &, cons_m30=-30.0, cons_50=50.0 -! - real (kind=kind_phys) rnp(im), psautco_l(im), prautco_l(im) & - &, wk2(im) -! - real (kind=kind_phys) err(im), ers(im), precrl(im) & - &, precsl(im), precrl1(im), precsl1(im) & - &, rq(im), condt(im) & - &, conde(im), rconde(im), tmt0(im) & - &, wmin(im,km), wmink(im), pres(im) & - &, wmini(im,km), ccr(im) & - &, tt(im), qq(im), ww(im) & - &, zaodt - real (kind=kind_phys) cclim(km) -! - integer iw(im,km), ipr(im), iwl(im), iwl1(im) -! - logical comput(im) -! - real (kind=kind_phys) ke, rdt, us, climit, cws, csm1 - &, crs1, crs2, cr, aa2, dtcp, c00, cmr - &, tem, c1, c2, wwn -! &, tem, c1, c2, u00b, u00t, wwn - &, precrk, precsk, pres1, qk, qw, qi - &, qint, fiw, wws, cwmk, expf - &, psaut, psaci, amaxcm, tem1, tem2 - &, tmt0k, psm1, psm2, ppr - &, rprs, erk, pps, sid, rid, amaxps - &, praut, fi, qc, amaxrq, rqkll - integer i, k, ihpr, n -! - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -!-------------- GFS psautco/prautco interstitial ---------------- - do i=1, im - wk2(i) = 1.0-wk1(i) - psautco_l(i) = psautco(1)*wk1(i) + psautco(2)*wk2(i) - prautco_l(i) = prautco(1)*wk1(i) + prautco(2)*wk2(i) - enddo -!-----------------------preliminaries --------------------------------- -! -! do k=1,km -! do i=1,im -! cll(i,k) = 0.0 -! enddo -! enddo -! - rdt = h1 / dt -! ke = 2.0e-5 ! commented on 09/10/99 -- opr value -! ke = 2.0e-6 -! ke = 1.0e-5 -!!! ke = 5.0e-5 -!! ke = 7.0e-5 - ke = evpco -! ke = 7.0e-5 - us = h1 - climit = 1.0e-20 - cws = 0.025 -! - zaodt = 800.0 * rdt -! - csm1 = 5.0000e-8 * zaodt - crs1 = 5.00000e-6 * zaodt - crs2 = 6.66600e-10 * zaodt - cr = 5.0e-4 * zaodt - aa2 = 1.25e-3 * zaodt -! - ke = ke * sqrt(rdt) -! ke = ke * sqrt(zaodt) -! - dtcp = dt * rcp -! -! c00 = 1.5e-1 * dt -! c00 = 10.0e-1 * dt -! c00 = 3.0e-1 * dt !05/09/2000 -! c00 = 1.0e-4 * dt !05/09/2000 -! c00 = prautco * dt !05/09/2000 - cmr = 1.0 / 3.0e-4 -! cmr = 1.0 / 5.0e-4 -! c1 = 100.0 - c1 = 300.0 - c2 = 0.5 -! -! -!--------calculate c0 and cmr using lc at previous step----------------- -! - do k=1,km - do i=1,im - tem = (prsl(i,k)*0.00001) -! tem = sqrt(tem) - iw(i,k) = 0.0 -! wmin(i,k) = 1.0e-5 * tem -! wmini(i,k) = 1.0e-5 * tem ! testing for ras -! - - wmin(i,k) = wminco(1) * tem - wmini(i,k) = wminco(2) * tem - - - rainp(i,k) = 0.0 - - enddo - enddo - do i=1,im -! c0(i) = 1.5e-1 -! cmr(i) = 3.0e-4 -! - iwl1(i) = 0 - precrl1(i) = d00 - precsl1(i) = d00 - comput(i) = .false. - rn(i) = d00 - sr(i) = d00 - ccr(i) = d00 -! - rnp(i) = d00 - enddo -!> -# Select columns where rain can be produced, where -!!\f[ -!! cwm > \min (wmin, wmini) -!!\f] -!! where the cloud water and ice conversion threshold: -!! \f[ -!! wmin=wminco(1)\times prsl\times 10^{-5} -!! \f] -!! \f[ -!! wmini=wminco(2)\times prsl\times 10^{-5} -!! \f] - -!------------select columns where rain can be produced-------------- - do k=1, km-1 - do i=1,im - tem = min(wmin(i,k), wmini(i,k)) - if (cwm(i,k) > tem) comput(i) = .true. - enddo - enddo - ihpr = 0 - do i=1,im - if (comput(i)) then - ihpr = ihpr + 1 - ipr(ihpr) = i - endif - enddo -!*********************************************************************** -!-----------------begining of precipitation calculation----------------- -!*********************************************************************** -! do k=km-1,2,-1 - do k=km,1,-1 - do n=1,ihpr - precrl(n) = precrl1(n) - precsl(n) = precsl1(n) - err (n) = d00 - ers (n) = d00 - iwl (n) = 0 -! - i = ipr(n) - tt(n) = t(i,k) - qq(n) = q(i,k) - ww(n) = cwm(i,k) - wmink(n) = wmin(i,k) - pres(n) = prsl(i,k) -! - precrk = max(cons_0, precrl1(n)) - precsk = max(cons_0, precsl1(n)) - wwn = max(ww(n), climit) -! if (wwn .gt. wmink(n) .or. (precrk+precsk) .gt. d00) then - if (wwn > climit .or. (precrk+precsk) > d00) then - comput(n) = .true. - else - comput(n) = .false. - endif - enddo -! -! es(1:ihpr) = fpvs(tt(1:ihpr)) - do n=1,ihpr - if (comput(n)) then - i = ipr(n) - conde(n) = (dt/g) * del(i,k) - condt(n) = conde(n) * rdt - rconde(n) = h1 / conde(n) - qk = max(epsq, qq(n)) - tmt0(n) = tt(n) - 273.16 - wwn = max(ww(n), climit) -! -! pl = pres(n) * 0.01 -! call qsatd(tt(n), pl, qc) -! rq(n) = max(qq(n), epsq) / max(qc, 1.0e-10) -! rq(n) = max(1.0e-10, rq(n)) ! -- relative humidity--- -! -! the global qsat computation is done in pa - pres1 = pres(n) -! qw = es(n) - qw = min(pres1, fpvs(tt(n))) - qw = eps * qw / (pres1 + epsm1 * qw) - qw = max(qw,epsq) -! -! tmt15 = min(tmt0(n), cons_m15) -! ai = 0.008855 -! bi = 1.0 -! if (tmt0(n) .lt. -20.0) then -! ai = 0.007225 -! bi = 0.9674 -! endif -! qi = qw * (bi + ai*min(tmt0(n),cons_0)) -! qint = qw * (1.-0.00032*tmt15*(tmt15+15.)) -! - qi = qw - qint = qw -! if (tmt0(n).le.-40.) qint = qi -! -!-------------------ice-water id number iw------------------------------ -!> -# Calculate ice-water identification number IW (see algorithm in -!! \ref condense). - if(tmt0(n) < -15.) then - fi = qk - u00k(i,k)*qi - if(fi > d00 .or. wwn > climit) then - iwl(n) = 1 - else - iwl(n) = 0 - endif -! endif - elseif (tmt0(n) >= 0.) then - iwl(n) = 0 -! -! if(tmt0(n).lt.0.0.and.tmt0(n).ge.-15.0) then - else - iwl(n) = 0 - if(iwl1(n) == 1 .and. wwn > climit) iwl(n) = 1 - endif -! -! if(tmt0(n).ge.0.) then -! iwl(n) = 0 -! endif -!----------------the satuation specific humidity------------------------ - fiw = float(iwl(n)) - qc = (h1-fiw)*qint + fiw*qi -!----------------the relative humidity---------------------------------- - if(qc <= 1.0e-10) then - rq(n) = d00 - else - rq(n) = qk / qc - endif -!----------------cloud cover ratio ccr---------------------------------- -!> -# Calculate cloud fraction \f$b\f$ (see algorithm in \ref condense) - if(rq(n) < u00k(i,k)) then - ccr(n) = d00 - elseif(rq(n) >= us) then - ccr(n) = us - else - rqkll = min(us,rq(n)) - ccr(n) = h1-sqrt((us-rqkll)/(us-u00k(i,k))) - endif -! - endif - enddo -!-------------------ice-water id number iwl------------------------------ -! do n=1,ihpr -! if (comput(n) .and. (ww(n) .gt. climit)) then -! if (tmt0(n) .lt. -15.0 -! * .or. (tmt0(n) .lt. 0.0 .and. iwl1(n) .eq. 1)) -! * iwl(n) = 1 -! cll(ipr(n),k) = 1.0 ! cloud cover! -! cll(ipr(n),k) = min(1.0, ww(n)*cclim(k)) ! cloud cover! -! endif -! enddo -! -!> -# Precipitation production by auto conversion and accretion -!! - The autoconversion of cloud ice to snow (\f$P_{saut}\f$) is simulated -!! using the equation from Lin et al.(1983)\cite lin_et_al_1983 -!!\f[ -!! P_{saut}=a_{1}(cwm-wmini) -!!\f] -!! Since snow production in this process is caused by the increase in -!! size of cloud ice particles due to depositional growth and -!! aggregation of small ice particles, \f$P_{saut}\f$ is a function of -!! temperature as determined by coefficient \f$a_{1}\f$, given by -!! \f[ -!! a_{1}=psautco \times dt \times exp\left[ 0.025\left(T-273.15\right)\right] -!! \f] -!! -!! - The accretion of cloud ice by snow (\f$P_{saci}\f$) in the -!! regions where cloud ice exists is simulated by -!!\f[ -!! P_{saci}=C_{s}cwm P_{s} -!!\f] -!! where \f$P_{s}\f$ is the precipitation rate of snow. The collection -!! coefficient \f$C_{s}\f$ is a function of temperature since the open -!! structures of ice crystals at relative warm temperatures are more -!! likely to stick, given a collision, than crystals of other shapes -!! (Rogers (1979) \cite rogers_1979). Above the freezing level, -!! \f$C_{s}\f$ is expressed by -!!\f[ -!! C_{s}=c_{1}exp\left[ 0.025\left(T-273.15\right)\right] -!!\f] -!! where \f$c_{1}=1.25\times 10^{-3} m^{2}kg^{-1}s^{-1}\f$ are used. -!! \f$C_{s}\f$ is set to zero below the freezing level. -!! -!--- precipitation production -- auto conversion and accretion -! - do n=1,ihpr - if (comput(n) .and. ccr(n) > 0.0) then - wws = ww(n) - cwmk = max(cons_0, wws) - i = ipr(n) -! amaxcm = max(cons_0, cwmk - wmink(n)) - if (iwl(n) == 1) then ! ice phase - amaxcm = max(cons_0, cwmk - wmini(i,k)) - expf = dt * exp(0.025*tmt0(n)) - psaut = min(cwmk, psautco_l(i)*expf*amaxcm) - ww(n) = ww(n) - psaut - cwmk = max(cons_0, ww(n)) -! cwmk = max(cons_0, ww(n)-wmini(i,k)) - psaci = min(cwmk, aa2*expf*precsl1(n)*cwmk) - - ww(n) = ww(n) - psaci - precsl(n) = precsl(n) + (wws - ww(n)) * condt(n) - else ! liquid water -! -!> - Following Sundqvist et al. (1989)\cite sundqvist_et_al_1989, -!! the autoconversion of cloud water to rain (\f$P_{raut}\f$) can be -!! parameterized from the cloud water mixing ratio \f$m\f$ and cloud -!! coverage \f$b\f$, that is, -!!\f[ -!! P_{raut}=(prautco \times dt )\times (cwm-wmin)\left\{1-exp[-(\frac{cwm-wmin}{m_{r}b})^{2}]\right\} -!!\f] -!! where \f$m_{r}\f$ is \f$3.0\times 10^{-4}\f$. -! for using sundqvist precip formulation of rain -! - amaxcm = max(cons_0, cwmk - wmink(n)) -!! amaxcm = cwmk - tem1 = precsl1(n) + precrl1(n) - tem2 = min(max(cons_0, 268.0-tt(n)), cons_20) - tem = (1.0+c1*sqrt(tem1*rdt)) * (1+c2*sqrt(tem2)) -! - tem2 = amaxcm * cmr * tem / max(ccr(n),cons_p01) - tem2 = min(cons_50, tem2*tem2) -! praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) - praut = (prautco_l(i)*dt) * tem * amaxcm - & * (1.0-exp(-tem2)) - praut = min(praut, cwmk) - ww(n) = ww(n) - praut -! -! - Calculate the accretion of cloud water by rain \f$P_{racw}\f$, -! can be expressed using the cloud mixing ratio \f$cwm\f$ and rainfall -! rate \f$P_{r}\f$: -!\f[ -! P_{racw}=C_{r}cwmP_{r} -!\f] -! where \f$C_{r}=5.0\times10^{-4}m^{2}kg^{-1}s^{-1}\f$ is the -! collection coeffiecient. Note that this process is not included in -! current operational physcics. -! below is for zhao's precip formulation (water) -! -! amaxcm = max(cons_0, cwmk - wmink(n)) -! praut = min(cwmk, c00*amaxcm*amaxcm) -! ww(n) = ww(n) - praut -! -! cwmk = max(cons_0, ww(n)) -! tem1 = precsl1(n) + precrl1(n) -! pracw = min(cwmk, cr*dt*tem1*cwmk) -! ww(n) = ww(n) - pracw -! - precrl(n) = precrl(n) + (wws - ww(n)) * condt(n) -! -!hchuang code change [+1l] : add record to record information in vertical -! turn rnp in unit of ww (cwm and q, kg/kg ???) - rnp(n) = rnp(n) + (wws - ww(n)) - endif - endif - enddo -!> -# Evaporation of precipitation (\f$E_{rr}\f$ and \f$E_{rs}\f$) -!!\n Evaporation of precipitation is an important process that moistens -!! the layers below cloud base. Through this process, some of the -!! precipitating water is evaporated back to the atmosphere and the -!! precipitation efficiency is reduced. -!! - Evaporation of rain is calculated using the equation (Sundqvist(1988)\cite sundqvist_1988): -!!\f[ -!! E_{rr}= evpco \times (u-f)(P_{r})^{\beta} -!!\f] -!! where \f$u\f$ is u00k, \f$f\f$ is the relative humidity. -!! \f$\beta = 0.5\f$ are empirical parameter. -!! - Evaporation of snow is calculated using the equation: -!!\f[ -!! E_{rs}=[C_{rs1}+C_{rs2}(T-273.15)](\frac{u-f}{u})P_{s} -!!\f] -!! where \f$C_{rs1}=5\times 10^{-6}m^{2}kg^{-1}s^{-1}\f$ and -!! \f$C_{rs2}=6.67\times 10^{-10}m^{2}kg^{-1}K^{-1}s^{-1}\f$. The -!! evaporation of melting snow below the freezing level is ignored in -!! this scheme because of the difficulty in the latent heat treatment -!! since the surface of a melting snowflake is usually covered by a -!! thin layer of liquid water. -! -!-----evaporation of precipitation------------------------- -!**** err & ers positive--->evaporation-- negtive--->condensation -! - do n=1,ihpr - if (comput(n)) then - i = ipr(n) - qk = max(epsq, qq(n)) - tmt0k = max(cons_m30, tmt0(n)) - precrk = max(cons_0, precrl(n)) - precsk = max(cons_0, precsl(n)) - amaxrq = max(cons_0, u00k(i,k)-rq(n)) * conde(n) -!---------------------------------------------------------------------- -! increase the evaporation for strong/light prec -!---------------------------------------------------------------------- - ppr = ke * amaxrq * sqrt(precrk) -! ppr = ke * amaxrq * sqrt(precrk*rdt) - if (tmt0(n) .ge. 0.) then - pps = 0. - else - pps = (crs1+crs2*tmt0k) * amaxrq * precsk / u00k(i,k) - end if -!---------------correct if over-evapo./cond. occurs-------------------- - erk=precrk+precsk - if(rq(n).ge.1.0e-10) erk = amaxrq * qk * rdt / rq(n) - if (ppr+pps .gt. abs(erk)) then - rprs = erk / (precrk+precsk) - ppr = precrk * rprs - pps = precsk * rprs - endif - ppr = min(ppr, precrk) - pps = min(pps, precsk) - err(n) = ppr * rconde(n) - ers(n) = pps * rconde(n) - precrl(n) = precrl(n) - ppr -!hchuang code change [+1l] : add record to record information in vertical -! use err for kg/kg/dt not the ppr (mm/dt=kg/m2/dt) -! - rnp(n) = rnp(n) - err(n) -! - precsl(n) = precsl(n) - pps - endif - enddo -!> -# Melting of snow (\f$P_{sm1}\f$ and \f$P_{sm2}\f$) -!!\n In this scheme, we allow snow melting to take place in certain -!! temperature regions below the freezing level in two ways. In both -!! cases, the melted snow is assumed to become raindrops. -!! - One is the continuous melting of snow due to the increase in -!! temperature as it falls down through the freezing level. This -!! process is parameterized as a function of temperature and snow -!! precipitation rate, that is, -!!\f[ -!! P_{sm1}=C_{sm}(T-273.15)^{2}P_{s} -!!\f] -!! where \f$C_{sm}=5\times 10^{-8}m^{2}kg^{-1}K^{-2}s^{-1}\f$ -!! cause the falling snow to melt almost completely before it reaches -!! the \f$T=278.15 K\f$ level. -!! - Another is the immediate melting of melting snow by collection of -!! the cloud water below the freezing level. In order to calculate the -!! melting rate, the collection rate of cloud water by melting snow is -!! computed first. Similar to the collection of cloud water by rain, -!! the collection of cloud water by melting snow can be parameterized -!! to be proportional to the cloud water mixing ratio \f$m\f$ and the -!! precipitation rate of snow \f$P_{s}\f$: -!!\f[ -!! P_{sacw}=C_{r}cwmP_{s} -!!\f] -!! where \f$C_{r}\f$ is the collection coefficient, -!! \f$C_{r}=5.0\times 10^{-4}m^{2}kg^{-1}s^{-1}\f$ . The melting rate -!! of snow then can be computed from -!!\f[ -!! P_{sm2}=C_{ws}P_{sacw} -!!\f] -!! where \f$C_{ws}=0.025\f$. -!--------------------melting of the snow-------------------------------- - do n=1,ihpr - if (comput(n)) then - if (tmt0(n) .gt. 0.) then - amaxps = max(cons_0, precsl(n)) - psm1 = csm1 * tmt0(n) * tmt0(n) * amaxps - psm2 = cws * cr * max(cons_0, ww(n)) * amaxps - ppr = (psm1 + psm2) * conde(n) - if (ppr .gt. amaxps) then - ppr = amaxps - psm1 = amaxps * rconde(n) - endif - precrl(n) = precrl(n) + ppr -! -!hchuang code change [+1l] : add record to record information in vertical -! turn ppr (mm/dt=kg/m2/dt) to kg/kg/dt -> ppr/air density (kg/m3) - rnp(n) = rnp(n) + ppr * rconde(n) -! - precsl(n) = precsl(n) - ppr - else - psm1 = d00 - endif -! -!---------------update t and q------------------------------------------ -!> - Update t and q. -!!\f[ -!! t=t-\frac{L}{C_{p}}(E_{rr}+E_{rs}+P_{sm1})\times dt -!!\f] -!!\f[ -!! q=q+(E_{rr}+E_{rs})\times dt -!!\f] - - tt(n) = tt(n) - dtcp * (elwv*err(n)+eliv*ers(n)+eliw*psm1) - qq(n) = qq(n) + dt * (err(n)+ers(n)) - endif - enddo -! - do n=1,ihpr - iwl1(n) = iwl(n) - precrl1(n) = max(cons_0, precrl(n)) - precsl1(n) = max(cons_0, precsl(n)) - i = ipr(n) - t(i,k) = tt(n) - q(i,k) = qq(n) - cwm(i,k) = ww(n) - iw(i,k) = iwl(n) -!hchuang code change [+1l] : add record to record information in vertical -! rnp = precrl1*rconde(n) unit in kg/kg/dt -! - rainp(i,k) = rnp(n) - enddo -! -! move water from vapor to liquid should the liquid amount be negative -! - do i = 1, im - if (cwm(i,k) < 0.) then - tem = q(i,k) + cwm(i,k) - if (tem >= 0.0) then - q(i,k) = tem - t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) - cwm(i,k) = 0. - elseif (q(i,k) > 0.0) then - cwm(i,k) = tem - t(i,k) = t(i,k) + elwv * rcp * q(i,k) - q(i,k) = 0.0 - endif - endif - enddo -! - enddo ! k loop ends here! -!********************************************************************** -!-----------------------end of precipitation processes----------------- -!********************************************************************** -! -!> -# Calculate precipitation at surface (\f$rn\f$)and determine -!! fraction of frozen precipitation (\f$sr\f$). -!!\f[ -!! rn= (P_{r}(\eta_{sfc})+P_{s}(\eta_{sfc}))/10^3 -!!\f] -!!\f[ -!! sr=\frac{P_{s}(\eta_{sfc})}{P_{s}(\eta_{sfc})+P_{r}(\eta_{sfc})} -!!\f] - do n=1,ihpr - i = ipr(n) - rn(i) = (precrl1(n) + precsl1(n)) * rrow ! precip at surface -! -!----sr=1 if sfc prec is rain ; ----sr=-1 if sfc prec is snow -!----sr=0 for both of them or no sfc prec -! -! rid = 0. -! sid = 0. -! if (precrl1(n) .ge. 1.e-13) rid = 1. -! if (precsl1(n) .ge. 1.e-13) sid = -1. -! sr(i) = rid + sid ! sr=1 --> rain, sr=-1 -->snow, sr=0 -->both -! chuang, june 2013: change sr to define fraction of frozen precipitation instead -! because wpc uses it in their winter experiment - - rid = precrl1(n) + precsl1(n) - if (rid < 1.e-13) then - sr(i) = 0. - else - sr(i) = precsl1(n)/rid - endif - enddo -! - return - end subroutine zhaocarr_precpd_run -!> @} - -!! \section arg_table_zhaocarr_precpd_finalize Argument Table -!! - subroutine zhaocarr_precpd_finalize - end subroutine zhaocarr_precpd_finalize - - - end module zhaocarr_precpd diff --git a/physics/sfcsub.F b/physics/sfcsub.F deleted file mode 100644 index 7c78707f5..000000000 --- a/physics/sfcsub.F +++ /dev/null @@ -1,8745 +0,0 @@ -!>\file sfcsub.F -!! This file contains gribcode for each parameter. - - -!>\defgroup mod_sfcsub_mod GFS sfcsub Module -!!\ingroup Noah_LSM -!> @{ -!>\ingroup mod_sfcsub -!! This module contains grib code for each parameter-used in subroutines sfccycle() -!! and setrmsk(). - module sfccyc_module - implicit none - save -! -! grib code for each parameter - used in subroutines sfccycle and setrmsk. -! - integer kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla, - & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg, - & kpdvet,kpdsot - &, kpdvmn,kpdvmx,kpdslp,kpdabs - &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) - parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, -! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, - 1 kpdais=91, kpdtg3=11, kpdplr=224, - 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, - 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, -!cbosu max snow albedo uses a grib id number of 159, not 255. - & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, - & kpdvet=225, kpdsot=224,kpdabs_1=159, - & kpdsnd=66 ) -! - integer, parameter :: kpdalb_0(4)=(/212,215,213,216/) - integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) - integer, parameter :: kpdalf(2)=(/214,217/) -! - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata - integer :: veg_type_landice - integer :: soil_type_landice -! - end module sfccyc_module - -!>\ingroup mod_sfcsub - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc - &, iy,im,id,ih,fh - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl - &, sihfcs,sicfcs,sitfcs - &, swdfcs,slcfcs - &, vmnfcs,vmxfcs,slpfcs,absfcs - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs - &, vegfcs,vetfcs,sotfcs,alffcs - &, cvfcs,cvbfcs,cvtfcs,me,nlunit - &, sz_nml,input_nml_file - &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) -! - use machine , only : kind_io8,kind_io4 - use sfccyc_module - implicit none - character(len=*), intent(in) :: tile_num_ch - integer,intent(in) :: i_index(len), j_index(len) - logical use_ufo, nst_anl - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, - & orolmx,orolmn,oroomx,oroomn,orosmx, - & orosmn,oroimx,oroimn,orojmx,orojmn, - & alblmx,alblmn,albomx,albomn,albsmx, - & albsmn,albimx,albimn,albjmx,albjmn, - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, - & snolmx,snolmn,snoomx,snoomn,snosmx, - & snosmn,snoimx,snoimn,snojmx,snojmn, - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, - & plrlmx,plrlmn,plromx,plromn,plrsmx, - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, - & stclmx,stclmn,stcomx,stcomn,stcsmx, - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, - & smclmx,smclmn,smcomx,smcomn,smcsmx, - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, - & veglmx,veglmn,vegomx,vegomn,vegsmx, - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, - & alslmx,alslmn,alsomx,alsomn,alssmx, - & alssmn,alsimx,alsimn,alsjmx,alsjmn, - & epstsf,epsalb,epssno,epswet,epszor, - & epsplr,epsoro,epssmc,epsscv,eptsfc, - & epstg3,epsais,epsacn,epsveg,epsvet, - & epssot,epsalf,qctsfs,qcsnos,qctsfi, - & aislim,snwmin,snwmax,cplrl,cplrs, - & cvegl,czors,csnol,csnos,czorl,csots, - & csotl,cvwgs,cvetl,cvets,calfs, - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, - & calbl,calfl,calbs,ctsfs,grboro, - & grbmsk,ctsfl,deltf,caisl,caiss, - & fsalfl,fsalfs,flalfs,falbl,ftsfl, - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, - & deltsfc,critp2,critp3,blnmsk,critp1, - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 - &, fsihl,fsihs,fsicl,fsics, - & csihl,csihs,csicl,csics,epssih,epssic - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, - & epsslp,epsabs - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, - & siclmx,siclmn,sicomx,sicomn,sicsmx, - & sicsmn,sicimx,sicimn,sicjmx,sicjmn - &, glacir_hice - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, - & slplmx,slplmn,slpomx,slpomn,slpsmx, - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, - & abslmx,abslmn,absomx,absomn,abssmx, - & abssmn,absimx,absimn,absjmx,absjmn - &, sihnew - - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, - & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, - & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, - & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb - &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, - & monfcs, monmer, mondif, landice - character(len=*), intent(in) :: input_nml_file(sz_nml) - - integer num_parthds -! -!> this is a limited point version of surface program. -!! -!! this program runs in two different modes: -!! -!! 1. analysis mode (fh=0.) -!! -!! this program merges climatology, analysis and forecast guess to create -!! new surface fields. if analysis file is given, the program -!! uses it if date of the analysis matches with iy,im,id,ih (see note -!! below). -!! -!! 2. forecast mode (fh.gt.0.) -!! -!! this program interpolates climatology to the date corresponding to the -!! forecast hour. if surface analysis file is given, for the corresponding -!! dates, the program will use it. -!! -!! note: -!! -!! if the date of the analysis does not match given iy,im,id,ih, (and fh), -!! the program searches an old analysis by going back 6 hours, then 12 hours, -!! then one day upto nrepmx days (parameter statement in the subrotine fixrd. -!! now defined as 8). this allows the user to provide non-daily analysis to -!! be used. if matching field is not found, the forecast guess will be used. -!! -!! use of a combined earlier surface analyses and current analysis is -!! not allowed (as was done in the old version for snow analysis in which -!! old snow analysis is used in combination with initial guess), except -!! for sea surface temperature. for sst anolmaly interpolation, you need to -!! set lanom=.true. and must provide sst analysis at initial time. -!! -!! if you want to do complex merging of past and present surface field analysis, -!! you need to create a separate file that contains daily surface field. -!! -!! for a dead start, do not supply fnbgsi or set fnbgsi=' ' -! -! lugb is the unit number used in this subprogram -! len ... number of points on which sfccyc operates -! lsoil .. number of soil layers (2 as of april, 1994) -! iy,im,id,ih .. year, month, day, and hour of initial state. -! fh .. forecast hour -! rla, rlo -- latitude and longitudes of the len points -! sig1t .. sigma level 1 temperature for dead start. should be on gaussian -! grid. if not dead start, no need for dimension but set to zero -! as in the example below. -! -! variable naming conventions: -! -! oro .. orography -! alb .. albedo -! wet .. soil wetness as defined for bucket model -! sno .. snow depth -! zor .. surface roughness length -! vet .. vegetation type -! plr .. plant evaporation resistance -! tsf .. surface skin temperature. sea surface temp. over ocean. -! tg3 .. deep soil temperature (at 500cm) -! stc .. soil temperature (lsoil layrs) -! smc .. soil moisture (lsoil layrs) -! scv .. snow cover (not snow depth) -! ais .. sea ice mask (0 or 1) -! acn .. sea ice concentration (fraction) -! gla .. glacier (permanent snow) mask (0 or 1) -! mxi .. maximum sea ice extent (0 or 1) -! msk .. land ocean mask (0=ocean 1=land) -! cnp .. canopy water content -! cv .. convective cloud cover -! cvb .. convective cloud base -! cvt .. convective cloud top -! sli .. land/sea/sea-ice mask. (1/0/2 respectively) -! veg .. vegetation cover -! sot .. soil type -!cwu [+2l] add sih & sic -! sih .. sea ice thickness -! sic .. sea ice concentration -!clu [+6l] add swd,slc,vmn,vmx,slp,abs -! swd .. actual snow depth -! slc .. liquid soil moisture (lsoil layers) -! vmn .. vegetation cover minimum -! vmx .. vegetation cover maximum -! slp .. slope type -! abs .. maximum snow albedo - -! -! definition of land/sea mask. sllnd for land and slsea for sea. -! definition of sea/ice mask. aicice for ice, aicsea for sea. -! tgice=max ice temperature -! rlapse=lapse rate for sst correction due to surface angulation -! - parameter(sllnd =1.0,slsea =0.0) - parameter(aicice=1.0,aicsea=0.0) - parameter(tgice=271.2) - parameter(rlapse=0.65e-2) -! -! max/min of fields for check and replace. -! -! ???lmx .. max over bare land -! ???lmn .. min over bare land -! ???omx .. max over open ocean -! ???omn .. min over open ocean -! ???smx .. max over snow surface (land and sea-ice) -! ???smn .. min over snow surface (land and sea-ice) -! ???imx .. max over bare sea ice -! ???imn .. min over bare sea ice -! ???jmx .. max over snow covered sea ice -! ???jmn .. min over snow covered sea ice -! - parameter(orolmx=8000.,orolmn=-1000.,oroomx=3000.,oroomn=-1000., - & orosmx=8000.,orosmn=-1000.,oroimx=3000.,oroimn=-1000., - & orojmx=3000.,orojmn=-1000.) -! parameter(alblmx=0.80,alblmn=0.06,albomx=0.06,albomn=0.06, -! & albsmx=0.80,albsmn=0.06,albimx=0.80,albimn=0.80, -! & albjmx=0.80,albjmn=0.80) -!cwu [-3l/+9l] change min/max for alb; add min/max for sih & sic -! parameter(alblmx=0.80,alblmn=0.01,albomx=0.01,albomn=0.01, -! & albsmx=0.80,albsmn=0.01,albimx=0.01,albimn=0.01, -! & albjmx=0.01,albjmn=0.01) -! note: the range values for bare land and snow covered land -! (alblmx, alblmn, albsmx, albsmn) are set below -! based on whether the old or new radiation is selected - parameter(albomx=0.06,albomn=0.06, - & albimx=0.80,albimn=0.06, - & albjmx=0.80,albjmn=0.06) - parameter(sihlmx=0.0,sihlmn=0.0,sihomx=5.0,sihomn=0.0, - & sihsmx=5.0,sihsmn=0.0,sihimx=5.0,sihimn=0.10, - & sihjmx=5.0,sihjmn=0.10,glacir_hice=3.0) -!cwu change sicimn & sicjmn Jan 2015 -! parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, -! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.50, -! & sicjmx=1.0,sicjmn=0.50) -! -! parameter(sihlmx=0.0,sihlmn=0.0,sihomx=8.0,sihomn=0.0, -! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, -! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) - parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, - & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, - & sicjmx=1.0,sicjmn=0.15) - - parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, - & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, - & wetjmx=0.15,wetjmn=0.15) - parameter(snolmx=0.0,snolmn=0.0,snoomx=0.0,snoomn=0.0, - & snosmx=55000.,snosmn=0.001,snoimx=0.,snoimn=0.0, - & snojmx=10000.,snojmn=0.01) - parameter(zorlmx=300.,zorlmn=1.0,zoromx=1.0,zoromn=1.e-05, - & zorsmx=300.,zorsmn=1.0,zorimx=1.0,zorimn=1.0, - & zorjmx=1.0,zorjmn=1.0) - parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, - & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, - & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx (for noah lsm) - parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, - & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, - & tsfjmx=273.16,tsfjmn=173.0) -! parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.21, -!* & tsfsmx=273.16,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, -! & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, - parameter(tg3lmx=310.,tg3lmn=200.0,tg3omx=310.0,tg3omn=200.0, - & tg3smx=310.,tg3smn=200.0,tg3imx=310.0,tg3imn=200.0, - & tg3jmx=310.,tg3jmn=200.0) - parameter(stclmx=353.,stclmn=173.0,stcomx=313.0,stcomn=200.0, - & stcsmx=310.,stcsmn=200.0,stcimx=310.0,stcimn=200.0, - & stcjmx=310.,stcjmn=200.0) -!landice mods force a flag value of soil moisture of 1.0 -! at non-land points - parameter(smclmx=0.55,smclmn=0.0,smcomx=1.0,smcomn=1.0, - & smcsmx=0.55,smcsmn=0.0,smcimx=1.0,smcimn=1.0, - & smcjmx=1.0,smcjmn=1.0) - parameter(scvlmx=0.0,scvlmn=0.0,scvomx=0.0,scvomn=0.0, - & scvsmx=1.0,scvsmn=1.0,scvimx=0.0,scvimn=0.0, - & scvjmx=1.0,scvjmn=1.0) - parameter(veglmx=1.0,veglmn=0.0,vegomx=0.0,vegomn=0.0, - & vegsmx=1.0,vegsmn=0.0,vegimx=0.0,vegimn=0.0, - & vegjmx=0.0,vegjmn=0.0) - parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, - & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, - & vmnjmx=0.0,vmnjmn=0.0) - parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, - & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, - & vmxjmx=0.0,vmxjmn=0.0) - parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, - & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., - & slpjmx=0.,slpjmn=0.) -! note: the range values for bare land and snow covered land -! (alblmx, alblmn, albsmx, albsmn) are set below -! based on whether the old or new radiation is selected - parameter(absomx=0.0,absomn=0.0, - & absimx=0.0,absimn=0.0, - & absjmx=0.0,absjmn=0.0) -! vegetation type - parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, - & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., - & vetjmx=0.,vetjmn=0.) -! soil type - parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0, - & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0., - & sotjmx=0.,sotjmn=0.) -! fraction of vegetation for strongly and weakly zeneith angle dependent -! albedo - parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0, - & alssmx=1.0,alssmn=0.0,alsimx=0.0,alsimn=0.0, - & alsjmx=0.0,alsjmn=0.0) -! -! criteria used for monitoring -! - parameter(epstsf=0.01,epsalb=0.001,epssno=0.01, - & epswet=0.01,epszor=0.0000001,epsplr=1.,epsoro=0., - & epssmc=0.0001,epsscv=0.,eptsfc=0.01,epstg3=0.01, - & epsais=0.,epsacn=0.01,epsveg=0.01, - & epssih=0.001,epssic=0.001, - & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01, - & epsvet=.01,epssot=.01,epsalf=.001) -! -! quality control of analysis snow and sea ice -! -! qctsfs .. surface temperature above which no snow allowed -! qcsnos .. snow depth above which snow must exist -! qctsfi .. sst above which sea-ice is not allowed -! -!clu relax qctsfs (for noah lsm) -!* parameter(qctsfs=283.16,qcsnos=100.,qctsfi=280.16) -!* parameter(qctsfs=288.16,qcsnos=100.,qctsfi=280.16) - parameter(qctsfs=293.16,qcsnos=100.,qctsfi=280.16) -! -!cwu [-2l] -!* ice concentration for ice limit (55 percent) -! -!* parameter(aislim=0.55) -! -! parameters to obtain snow depth from snow cover and temperature -! -! parameter(snwmin=25.,snwmax=100.) - parameter(snwmin=5.0,snwmax=100.) - real (kind=kind_io8), parameter :: ten=10.0, one=1.0 -! -! coeeficients of blending forecast and interpolated clim -! (or analyzed) fields over sea or land(l) (not for clouds) -! 1.0 = use of forecast -! 0.0 = replace with interpolated analysis -! -! these values are set for analysis mode. -! -! variables land sea -! --------------------------------------------------------- -! surface temperature forecast analysis -! surface temperature forecast forecast (over sea ice) -! albedo analysis analysis -! sea-ice analysis analysis -! snow analysis forecast (over sea ice) -! roughness analysis forecast -! plant resistance analysis analysis -! soil wetness (layer) weighted average analysis -! soil temperature forecast analysis -! canopy waver content forecast forecast -! convective cloud cover forecast forecast -! convective cloud bottm forecast forecast -! convective cloud top forecast forecast -! vegetation cover analysis analysis -! vegetation type analysis analysis -! soil type analysis analysis -! sea-ice thickness forecast forecast -! sea-ice concentration analysis analysis -! vegetation cover min analysis analysis -! vegetation cover max analysis analysis -! max snow albedo analysis analysis -! slope type analysis analysis -! liquid soil wetness analysis-weighted analysis -! actual snow depth analysis-weighted analysis -! -! note: if analysis file is not given, then time interpolated climatology -! is used. if analyiss file is given, it will be used as far as the -! date and time matches. if they do not match, it uses forecast. -! -! critical percentage value for aborting bad points when lgchek=.true. -! - logical lgchek - data lgchek/.true./ - data critp1,critp2,critp3/80.,80.,25./ -! -! integer kpdalb(4), kpdalf(2) -! data kpdalb/212,215,213,216/, kpdalf/214,217/ -! save kpdalb, kpdalf -! -! mask orography and variance on gaussian grid -! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) - &, orogd(len) - real (kind=kind_io8) rla(len), rlo(len) -! -! permanent/extremes -! - character*500 fnglac,fnmxic - real (kind=kind_io8), allocatable :: glacir(:),amxice(:),tsfcl0(:) -! -! tsfcl0 is the climatological tsf at fh=0 -! -! climatology surface fields (last character 'c' or 'clm' indicate climatology) -! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), - & zorclm(len), albclm(len,4), aisclm(len), - & tg3clm(len), acnclm(len), cnpclm(len), - & cvclm (len), cvbclm(len), cvtclm(len), - & scvclm(len), tsfcl2(len), vegclm(len), - & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), - & smcclm(len,lsoil), stcclm(len,lsoil) - &, sihclm(len), sicclm(len) - &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) -! -! analyzed surface fields (last character 'a' or 'anl' indicate analysis) -! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota - &, fnvmna,fnvmxa,fnslpa,fnabsa -! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), cnpanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & scvanl(len), tsfan2(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), - & smcanl(len,lsoil), stcanl(len,lsoil) - &, sihanl(len), sicanl(len) - &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) -! - real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. -! -! predicted surface fields (last characters 'fcs' indicates forecast) -! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & tg3fcs(len), acnfcs(len), cnpfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2), - & smcfcs(len,lsoil), stcfcs(len,lsoil) - &, sihfcs(len), sicfcs(len), sitfcs(len) - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) - &, swdfcs(len), slcfcs(len,lsoil) -! -! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched -! in this program). -! - real (kind=kind_io8) f10m (len) - real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) - real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) - -!clu [+1l] add swratio (soil moisture liquid-to-total ratio) - real (kind=kind_io8) swratio(len,lsoil) -!clu [+1l] add fixratio (option to adjust slc from smc) - logical fixratio(lsoil) -! - integer icsmcl(25), icsmcs(25), icstcl(25), icstcs(25) -! - real (kind=kind_io8) csmcl(25), csmcs(25) - real (kind=kind_io8) cstcl(25), cstcs(25) -! - real (kind=kind_io8) slmskh(mdata) - character*500 fnmskh - integer kpd7, kpd9 -! - logical icefl1(len), icefl2(len) -! -! input and output surface fields (bges) file names -! -! -! sigma level 1 temperature for dead start -! - real (kind=kind_io8) sig1t(len) -! - character*32 label -! -! = 1 ==> forecast is used -! = 0 ==> analysis (or climatology) is used -! -! output file ... primary surface file for radiation and forecast -! -! rec. 1 label -! rec. 2 date record -! rec. 3 tsf -! rec. 4 soilm(two layers) ----> 4 layers -! rec. 5 snow -! rec. 6 soilt(two layers) ----> 4 layers -! rec. 7 tg3 -! rec. 8 zor -! rec. 9 cv -! rec. 10 cvb -! rec. 11 cvt -! rec. 12 albedo (four types) -! rec. 13 slimsk -! rec. 14 vegetation cover -! rec. 14 plantr -----> skip this record -! rec. 15 f10m -----> canopy -! rec. 16 canopy water content (cnpanl) -----> f10m -! rec. 17 vegetation type -! rec. 18 soil type -! rec. 19 zeneith angle dependent vegetation fraction (two types) -! rec. 20 uustar -! rec. 21 ffmm -! rec. 22 ffhh -!cwu add sih & sic -! rec. 23 sih(one category only) -! rec. 24 sic -!clu [+8l] add prcp, flag, swd, slc, vmn, vmx, slp, abs -! rec. 25 tprcp -! rec. 26 srflag -! rec. 27 swd -! rec. 28 slc (4 layers) -! rec. 29 vmn -! rec. 30 vmx -! rec. 31 slp -! rec. 32 abs - -! -! debug only -! ldebug=.true. creates bges files for climatology and analysis -! lqcbgs=.true. quality controls input bges file before merging (should have been -! qced in the forecast program) -! - logical ldebug,lqcbgs - logical lprnt -! -! debug only -! - character*500 fndclm,fndanl -! - logical lanom - -! - namelist/namsfc/fnglac,fnmxic, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc,fnalbc2, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota, - & fnvmna,fnvmxa,fnslpa,fnabsa, - & fnmskh, - & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, - & fndclm,fndanl, - & lanom, - & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, - & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs, - & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, - & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, - & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, - & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs, - & fsihl,fsicl,fsihs,fsics,aislim,sihnew, - & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss, - & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, - & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, - & icstcl,icstcs,icalfl,icalfs, - & gausm, deads, qcmsk, znlst, - & monclm, monanl, monfcs, monmer, mondif, igrdbg, - & blnmsk, bltmsk, landice -! - data gausm/.true./, deads/.false./, blnmsk/0.0/, bltmsk/90.0/ - &, qcmsk/.false./, znlst/.false./, igrdbg/-1/ - &, monclm/.false./, monanl/.false./, monfcs/.false./ - &, monmer/.false./, mondif/.false./, landice/.true./ -! -! defaults file names -! - data fnmskh/'global_slmask.t126.grb'/ - data fnalbc/'global_albedo4.1x1.grb'/ - data fnalbc2/'global_albedo4.1x1.grb'/ - data fntsfc/'global_sstclim.2x2.grb'/ - data fnsotc/'global_soiltype.1x1.grb'/ - data fnvegc/'global_vegfrac.1x1.grb'/ - data fnvetc/'global_vegtype.1x1.grb'/ - data fnglac/'global_glacier.2x2.grb'/ - data fnmxic/'global_maxice.2x2.grb'/ - data fnsnoc/'global_snoclim.1.875.grb'/ - data fnzorc/'global_zorclim.1x1.grb'/ - data fnaisc/'global_iceclim.2x2.grb'/ - data fntg3c/'global_tg3clim.2.6x1.5.grb'/ - data fnsmcc/'global_soilmcpc.1x1.grb'/ -!clu [+4l] add fn()c for vmn, vmx, abs, slp - data fnvmnc/'global_shdmin.0.144x0.144.grb'/ - data fnvmxc/'global_shdmax.0.144x0.144.grb'/ - data fnslpc/'global_slope.1x1.grb'/ - data fnabsc/'global_snoalb.1x1.grb'/ -! - data fnwetc/' '/ - data fnplrc/' '/ - data fnstcc/' '/ - data fnscvc/' '/ - data fnacnc/' '/ -! - data fntsfa/' '/ - data fnweta/' '/ - data fnsnoa/' '/ - data fnzora/' '/ - data fnalba/' '/ - data fnaisa/' '/ - data fnplra/' '/ - data fntg3a/' '/ - data fnsmca/' '/ - data fnstca/' '/ - data fnscva/' '/ - data fnacna/' '/ - data fnvega/' '/ - data fnveta/' '/ - data fnsota/' '/ -!clu [+4l] add fn()a for vmn, vmx, abs, slp - data fnvmna/' '/ - data fnvmxa/' '/ - data fnslpa/' '/ - data fnabsa/' '/ -! - data ldebug/.false./, lqcbgs/.true./ - data fndclm/' '/ - data fndanl/' '/ - data lanom/.false./ -! -! default relaxation time in hours to analysis or climatology - data ftsfl/99999.0/, ftsfs/0.0/ - data falbl/0.0/, falbs/0.0/ - data falfl/0.0/, falfs/0.0/ - data faisl/0.0/, faiss/0.0/ - data fsnol/0.0/, fsnos/99999.0/ - data fzorl/0.0/, fzors/99999.0/ - data fplrl/0.0/, fplrs/0.0/ - data fvetl/0.0/, fvets/99999.0/ - data fsotl/0.0/, fsots/99999.0/ - data fvegl/0.0/, fvegs/99999.0/ -!cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim - data fsihl/99999.0/, fsihs/99999.0/ -! data fsicl/99999.0/, fsics/99999.0/ - data fsicl/0.0/, fsics/0.0/ -! default ice concentration limit (50%), new ice thickness (20cm) -!cwu change ice concentration limit (15%) Jan 2015 -! data aislim/0.50/, sihnew/0.2/ - data aislim/0.15/, sihnew/0.2/ -!clu [+4l] add f()l and f()s for vmn, vmx, abs, slp - data fvmnl/0.0/, fvmns/99999.0/ - data fvmxl/0.0/, fvmxs/99999.0/ - data fslpl/0.0/, fslps/99999.0/ - data fabsl/0.0/, fabss/99999.0/ -! default relaxation time in hours to climatology if analysis missing - data fctsfl/99999.0/, fctsfs/99999.0/ - data fcalbl/99999.0/, fcalbs/99999.0/ - data fcsnol/99999.0/, fcsnos/99999.0/ - data fczorl/99999.0/, fczors/99999.0/ - data fcplrl/99999.0/, fcplrs/99999.0/ -! default flag to apply climatological annual cycle - data ictsfl/0/, ictsfs/1/ - data icalbl/1/, icalbs/1/ - data icalfl/1/, icalfs/1/ - data icsnol/0/, icsnos/0/ - data iczorl/1/, iczors/0/ - data icplrl/1/, icplrs/0/ -! - data ccnp/1.0/ - data ccv/1.0/, ccvb/1.0/, ccvt/1.0/ -! - data ifp/0/ -! - save ifp,fnglac,fnmxic, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnvetc,fnveta, - & fnsotc,fnsota, -!clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs - & fnvmnc,fnvmxc,fnabsc,fnslpc, - & fnvmna,fnvmxa,fnabsa,fnslpa, - & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, - & fndclm,fndanl, - & lanom, - & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, - & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs, - & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, - & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, - & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, - & fcstcl,fcstcs,fcalfl,fcalfs, -!cwu [+1l] add f()l and f()s for sih, sic and aislim, sihnew - & fsihl,fsihs,fsicl,fsics,aislim,sihnew, -!clu [+2l] add f()l and f()s for vmn, vmx, slp, abs - & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss, - & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, - & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, - & icstcl,icstcs,icalfl,icalfs, - & gausm, deads, qcmsk, - & monclm, monanl, monfcs, monmer, mondif, igrdbg, - & grboro, grbmsk, -! - & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs, - & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl, - & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots, - & csmcl -!cwu [+1l] add c()l and c()s for sih, sic - &, csihl, csihs, csicl, csics -!clu [+2l] add c()l and c()s for vmn, vmx, slp, abs - &, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps, - & cabsl, cabss - &, imsk, jmsk, slmskh, blnmsk, bltmsk - &, glacir, amxice, tsfcl0 - &, caisl, caiss, cvegs -! - lprnt = .false. - iprnt = 1 -! do i=1,len -! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) -! *,' rlo=',rlo(i) -! tem1 = abs(rla(i) - 48.75) -! tem2 = abs(rlo(i) - (-68.50)) -! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then -! lprnt = .true. -! iprnt = i -! print *,' lprnt=',lprnt,' iprnt=',iprnt -! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) -! endif -! enddo - if (ialb == 1) then - kpdabs = kpdabs_1 - kpdalb = kpdalb_1 - alblmx = .99 - albsmx = .99 - alblmn = .01 - albsmn = .01 - abslmx = 1.0 - abssmx = 1.0 - abssmn = .01 - abslmn = .01 - else - kpdabs = kpdabs_0 - kpdalb = kpdalb_0 - alblmx = .80 - albsmx = .80 - alblmn = .06 - albsmn = .06 - abslmx = .80 - abssmx = .80 - abslmn = .01 - abssmn = .01 - endif - if(ifp.eq.0) then - ifp = 1 - do k=1,lsoil - fsmcl(k) = 99999. - fsmcs(k) = 0. - fstcl(k) = 99999. - fstcs(k) = 0. - enddo -#ifdef INTERNAL_FILE_NML - read(input_nml_file, nml=namsfc) -#else -! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb - rewind(nlunit) - read (nlunit,namsfc) -#endif -! write(6,namsfc) -! - if (me .eq. 0) then - print *,'ftsfl,falbl,faisl,fsnol,fzorl=', - & ftsfl,falbl,faisl,fsnol,fzorl - print *,'fsmcl=',fsmcl(1:lsoil) - print *,'fstcl=',fstcl(1:lsoil) - print *,'ftsfs,falbs,faiss,fsnos,fzors=', - & ftsfs,falbs,faiss,fsnos,fzors - print *,'fsmcs=',fsmcs(1:lsoil) - print *,'fstcs=',fstcs(1:lsoil) - print *,' aislim=',aislim,' sihnew=',sihnew - print *,' isot=', isot,' ivegsrc=',ivegsrc - endif - - if (ivegsrc == 2) then ! sib - veg_type_landice=13 - else - veg_type_landice=15 - endif - if (isot == 0) then - soil_type_landice=9 - else - soil_type_landice=16 - endif -! - deltf = deltsfc / 24.0 -! - ctsfl=0. !... tsfc over land - if(ftsfl.ge.99999.) ctsfl=1. - if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) -! - ctsfs=0. !... tsfc over sea - if(ftsfs.ge.99999.) ctsfs=1. - if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) -! - do k=1,lsoil - csmcl(k)=0. !... soilm over land - if(fsmcl(k).ge.99999.) csmcl(k)=1. - if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) - & csmcl(k)=exp(-deltf/fsmcl(k)) - csmcs(k)=0. !... soilm over sea - if(fsmcs(k).ge.99999.) csmcs(k)=1. - if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) - & csmcs(k)=exp(-deltf/fsmcs(k)) - enddo -! - calbl=0. !... albedo over land - if(falbl.ge.99999.) calbl=1. - if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) -! - calfl=0. !... fraction field for albedo over land - if(falfl.ge.99999.) calfl=1. - if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) -! - calbs=0. !... albedo over sea - if(falbs.ge.99999.) calbs=1. - if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) -! - calfs=0. !... fraction field for albedo over sea - if(falfs.ge.99999.) calfs=1. - if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) -! - caisl=0. !... sea ice over land - if(faisl.ge.99999.) caisl=1. - if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. -! - caiss=0. !... sea ice over sea - if(faiss.ge.99999.) caiss=1. - if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. -! - csnol=0. !... snow over land - if(fsnol.ge.99999.) csnol=1. - if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) -! using the same way to bending snow as narr when fsnol is the negative value -! the magnitude of fsnol is the thread to determine the lower and upper bound -! of final swe - if(fsnol.lt.0.)csnol=fsnol -! - csnos=0. !... snow over sea - if(fsnos.ge.99999.) csnos=1. - if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) -! - czorl=0. !... roughness length over land - if(fzorl.ge.99999.) czorl=1. - if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) -! - czors=0. !... roughness length over sea - if(fzors.ge.99999.) czors=1. - if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) -! -! cplrl=0. !... plant resistance over land -! if(fplrl.ge.99999.) cplrl=1. -! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) -! -! cplrs=0. !... plant resistance over sea -! if(fplrs.ge.99999.) cplrs=1. -! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) -! - do k=1,lsoil - cstcl(k)=0. !... soilt over land - if(fstcl(k).ge.99999.) cstcl(k)=1. - if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) - & cstcl(k)=exp(-deltf/fstcl(k)) - cstcs(k)=0. !... soilt over sea - if(fstcs(k).ge.99999.) cstcs(k)=1. - if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) - & cstcs(k)=exp(-deltf/fstcs(k)) - enddo -! - cvegl=0. !... vegetation fraction over land - if(fvegl.ge.99999.) cvegl=1. - if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) -! - cvegs=0. !... vegetation fraction over sea - if(fvegs.ge.99999.) cvegs=1. - if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) -! - cvetl=0. !... vegetation type over land - if(fvetl.ge.99999.) cvetl=1. - if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) -! - cvets=0. !... vegetation type over sea - if(fvets.ge.99999.) cvets=1. - if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) -! - csotl=0. !... soil type over land - if(fsotl.ge.99999.) csotl=1. - if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) -! - csots=0. !... soil type over sea - if(fsots.ge.99999.) csots=1. - if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) - -!cwu [+16l]--------------------------------------------------------------- -! - csihl=0. !... sea ice thickness over land - if(fsihl.ge.99999.) csihl=1. - if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) -! - csihs=0. !... sea ice thickness over sea - if(fsihs.ge.99999.) csihs=1. - if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) -! - csicl=0. !... sea ice concentration over land - if(fsicl.ge.99999.) csicl=1. - if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) -! - csics=0. !... sea ice concentration over sea - if(fsics.ge.99999.) csics=1. - if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) - -!clu [+32l]--------------------------------------------------------------- -! - cvmnl=0. !... min veg cover over land - if(fvmnl.ge.99999.) cvmnl=1. - if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) -! - cvmns=0. !... min veg cover over sea - if(fvmns.ge.99999.) cvmns=1. - if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) -! - cvmxl=0. !... max veg cover over land - if(fvmxl.ge.99999.) cvmxl=1. - if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) -! - cvmxs=0. !... max veg cover over sea - if(fvmxs.ge.99999.) cvmxs=1. - if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) -! - cslpl=0. !... slope type over land - if(fslpl.ge.99999.) cslpl=1. - if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) -! - cslps=0. !... slope type over sea - if(fslps.ge.99999.) cslps=1. - if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) -! - cabsl=0. !... snow albedo over land - if(fabsl.ge.99999.) cabsl=1. - if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) -! - cabss=0. !... snow albedo over sea - if(fabss.ge.99999.) cabss=1. - if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) -!clu ---------------------------------------------------------------------- -! -! read a high resolution mask field for use in grib interpolation -! - call hmskrd(lugb,imsk,jmsk,fnmskh, - & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) -! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) -! - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil - write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh - &, ' sig1t(1)=',sig1t(1) - &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk - write(6,*) ' ' - endif -! -! reading permanent/extreme features (glacier points and maximum ice extent) -! - allocate (tsfcl0(len)) - allocate (glacir(len)) - allocate (amxice(len)) -! -! read glacier -! - kpd9 = -1 - kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, - & glacir,len,iret - &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk - &, rla, rlo, me) -! znnt=1. -! call nntprt(glacir,len,znnt) -! -! read maximum ice extent -! - kpd7 = -1 - call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, - & amxice,len,iret - &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk - &, rla, rlo, me) -! znnt=1. -! call nntprt(amxice,len,znnt) -! - crit=0.5 - call rof01(glacir,len,'ge',crit) - call rof01(amxice,len,'ge',crit) -! -! quality control max ice limit based on glacier points -! - call qcmxice(glacir,amxice,len,me) -! - endif ! first time loop finished -! - do i=1,len - sliclm(i) = 1. - snoclm(i) = 0. - icefl1(i) = .true. - enddo -! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) -! -! read climatology fields -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) 'climatology' - write(6,*) '==============' - endif -! - percrit=critp1 -! - call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, - & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me - &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) -! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) -! -! scale surface roughness and albedo to model required units -! - zsca=100. - call scale(zorclm,len,zsca) - zsca=0.01 - call scale(albclm,len,zsca) - call scale(albclm(1,2),len,zsca) - call scale(albclm(1,3),len,zsca) - call scale(albclm(1,4),len,zsca) - call scale(alfclm,len,zsca) - call scale(alfclm(1,2),len,zsca) -!clu [+4l] scale vmn, vmx, abs from percent to fraction - zsca=0.01 - call scale(vmnclm,len,zsca) - call scale(vmxclm,len,zsca) - call scale(absclm,len,zsca) - -! -! set albedo over ocean to albomx -! - call albocn(albclm,slmask,albomx,len) -! -! make sure vegetation type and soil type are non zero over land -! - call landtyp(vetclm,sotclm,slpclm,slmask,len) -! -!cwu [-1l/+1l] -!* ice concentration or ice mask (only ice mask used in the model now) -! ice concentration and ice mask (both are used in the model now) -! - if(fnaisc(1:8).ne.' ') then -!cwu [+5l/-1l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*aisclm(i) - sicclm(i) = aisclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 - call rof01(aisclm,len,'ge',crit) - elseif(fnacnc(1:8).ne.' ') then -!cwu [+4l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*acnclm(i) - sicclm(i) = acnclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - call rof01(acnclm,len,'ge',aislim) - do i=1,len - aisclm(i) = acnclm(i) - enddo - endif -! -! quality control of sea ice mask -! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmask,aisclm,len,aicice,sliclm) -! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmask=',slmask(iprnt) -! -! write(6,*) 'sliclm' -! znnt=1. -! call nntprt(sliclm,len,znnt) -! -! quality control of snow -! - call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) -! - call setzro(snoclm,epssno,len) -! -! snow cover handling (we assume climatological snow depth is available) -! quality control of snow depth (note that snow should be corrected first -! because it influences tsf -! - kqcm=1 - call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! write(6,*) 'snoclm' -! znnt=1. -! call nntprt(snoclm,len,znnt) -! -! get snow cover from snow depth array -! - if(fnscvc(1:8).eq.' ') then - call getscv(snoclm,scvclm,len) - endif -! -! set tsfc over snow to tsfsmx if greater -! - call snosfc(snoclm,tsfclm,tsfsmx,len,me) -! call snosfc(snoclm,tsfcl2,tsfsmx,len) - -! -! quality control -! - do i=1,len - icefl2(i) = sicclm(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsf2 ',tsfcl2,sliclm,snoclm,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albc ',albclm(1,kk),sliclm,snoclm,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ') then - call qcmxmn('wetc ',wetclm,sliclm,snoclm,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorc ',zorclm,sliclm,snoclm,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ') then -! call qcmxmn('plntc ',plrclm,sliclm,snoclm,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3c ',tg3clm,sliclm,snoclm,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! get soil temp and moisture (after all the qcs are completed) -! - if(fnsmcc(1:8).eq.' ') then - call getsmc(wetclm,len,lsoil,smcclm,me) - endif - call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if(fnstcc(1:8).eq.' ') then - call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) - endif - call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetc ',vetclm,sliclm,snoclm,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotc ',sotclm,sliclm,snoclm,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] --------------------------------------------------------------- - call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l] --------------------------------------------------------------- - call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxc ',vmxclm,sliclm,snoclm,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpc ',slpclm,sliclm,snoclm,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absc ',absclm,sliclm,snoclm,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ---------------------------------------------------------------------- -! -! monitoring prints -! - if (monclm) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of time and space interpolated climatology' - print *,' ' -! call count(sliclm,snoclm,len) - print *,' ' - call monitr('tsfclm',tsfclm,sliclm,snoclm,len) - call monitr('albclm',albclm(1,1),sliclm,snoclm,len) - call monitr('albclm',albclm(1,2),sliclm,snoclm,len) - call monitr('albclm',albclm(1,3),sliclm,snoclm,len) - call monitr('albclm',albclm(1,4),sliclm,snoclm,len) - call monitr('aisclm',aisclm,sliclm,snoclm,len) - call monitr('snoclm',snoclm,sliclm,snoclm,len) - call monitr('scvclm',scvclm,sliclm,snoclm,len) - call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) - call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) - call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) - call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) -!clu [+4l] add smcclm(3:4) and stcclm(3:4) - if(lsoil.gt.2) then - call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) - call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) - call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) - call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) - endif - call monitr('tg3clm',tg3clm,sliclm,snoclm,len) - call monitr('zorclm',zorclm,sliclm,snoclm,len) -! if (gaus) then - call monitr('cvaclm',cvclm ,sliclm,snoclm,len) - call monitr('cvbclm',cvbclm,sliclm,snoclm,len) - call monitr('cvtclm',cvtclm,sliclm,snoclm,len) -! endif - call monitr('sliclm',sliclm,sliclm,snoclm,len) -! call monitr('plrclm',plrclm,sliclm,snoclm,len) - call monitr('orog ',orog ,sliclm,snoclm,len) - call monitr('vegclm',vegclm,sliclm,snoclm,len) - call monitr('vetclm',vetclm,sliclm,snoclm,len) - call monitr('sotclm',sotclm,sliclm,snoclm,len) -!cwu [+2l] add sih, sic - call monitr('sihclm',sihclm,sliclm,snoclm,len) - call monitr('sicclm',sicclm,sliclm,snoclm,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnclm',vmnclm,sliclm,snoclm,len) - call monitr('vmxclm',vmxclm,sliclm,snoclm,len) - call monitr('slpclm',slpclm,sliclm,snoclm,len) - call monitr('absclm',absclm,sliclm,snoclm,len) - endif - endif -! -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) ' analysis' - write(6,*) '==============' - endif -! -! fill in analysis array with climatology before reading analysis. -! - call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, - & sihclm,sicclm, - & vmnclm,vmxclm,slpclm,absclm, - & len,lsoil) -! -! reverse scaling to match with grib analysis input -! - zsca=0.01 - call scale(zoranl,len, zsca) - zsca=100. - call scale(albanl,len,zsca) - call scale(albanl(1,2),len,zsca) - call scale(albanl(1,3),len,zsca) - call scale(albanl(1,4),len,zsca) - call scale(alfanl,len,zsca) - call scale(alfanl(1,2),len,zsca) -!clu [+4l] reverse scale for vmn, vmx, abs - zsca=100. - call scale(vmnanl,len,zsca) - call scale(vmxanl,len,zsca) - call scale(absanl,len,zsca) -! - percrit=critp2 -! -! read analysis fields -! - call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, - & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, - & vmnanl,vmxanl,slpanl,absanl, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf - &, irtvmn,irtvmx,irtslp,irtabs, - & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk - &, me, lanom) -! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) -! -! scale zor and alb to match forecast model units -! - zsca=100. - call scale(zoranl,len, zsca) - zsca=0.01 - call scale(albanl,len,zsca) - call scale(albanl(1,2),len,zsca) - call scale(albanl(1,3),len,zsca) - call scale(albanl(1,4),len,zsca) - call scale(alfanl,len,zsca) - call scale(alfanl(1,2),len,zsca) -!clu [+4] scale vmn, vmx, abs from percent to fraction - zsca=0.01 - call scale(vmnanl,len,zsca) - call scale(vmxanl,len,zsca) - call scale(absanl,len,zsca) -! -! interpolate climatology but fixing initial anomaly -! - if(fh > 0.0 .and. fntsfa(1:8) /= ' ' .and. lanom) then - call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) - endif -! -! if the tsfanl is at sea level, then bring it to the surface using -! unfiltered orography (for lakes). if the analysis is at lake surface -! as in the nst model, then this call should be removed - moorthi 09/23/2011 -! - if (use_ufo .and. .not. nst_anl) then - ztsfc = 0.0 - call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) - endif -! -! ice concentration or ice mask (only ice mask used in the model now) -! - if(fnaisa(1:8).ne.' ') then -!cwu [+5l/-1l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*aisanl(i) - sicanl(i) = aisanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 - call rof01(aisanl,len,'ge',crit) - elseif(fnacna(1:8).ne.' ') then -!cwu [+17l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*acnanl(i) - sicanl(i) = acnanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim - do i=1,len - if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then - slianl(i)=2. -! print *,'cycle - new ice form: fice=',sicanl(i) - else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then - slianl(i)=0. -! print *,'cycle - ice free: fice=',sicanl(i) - else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i)=0. - endif - enddo -! znnt=10. -! call nntprt(acnanl,len,znnt) -! if(lprnt) print *,' acnanl=',acnanl(iprnt) -! do i=1,len -! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0 -! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim -! enddo -! if(lprnt) print *,' acnanl=',acnanl(iprnt) - call rof01(acnanl,len,'ge',aislim) - do i=1,len - aisanl(i)=acnanl(i) - enddo - endif -! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmask=',slmask(iprnt) -! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmask,aisanl,len,aicice,slianl) -! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmask=',slmask(iprnt) -! -! - do k=1,lsoil - do i=1,len - if (slianl(i) .eq. 0) then - smcanl(i,k) = smcomx - stcanl(i,k) = tsfanl(i) - endif - enddo - enddo - -! write(6,*) 'slianl' -! znnt=1. -! call nntprt(slianl,len,znnt) -!cwu [+8l]---------------------------------------------------------------------- - call qcmxmn('siha ',sihanl,slianl,snoanl,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! set albedo over ocean to albomx -! - call albocn(albanl,slmask,albomx,len) -! -! quality control of snow and sea-ice -! process snow depth or snow cover -! - if(fnsnoa(1:8).ne.' ') then - call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) - if (.not.landice) then - call snodpth2(glacir,snosmx,snoanl, len, me) - endif - kqcm=1 - call snosfc(snoanl,tsfanl,tsfsmx,len,me) - call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call getscv(snoanl,scvanl,len) - call qcmxmn('sncva ',scvanl,slianl,snoanl,icefl1, - & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, - & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, - & rla,rlo,len,kqcm,percrit,lgchek,me) - else - crit=0.5 - call rof01(scvanl,len,'ge',crit) - call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) - call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, - & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, - & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call snodpth(scvanl,slianl,tsfanl,snoclm, - & glacir,snwmax,snwmin,landice,len,snoanl,me) - call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) - call snosfc(snoanl,tsfanl,tsfsmx,len,me) - call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif -! - do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 - enddo - call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('alba ',albanl(1,kk),slianl,snoanl,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then - call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zora ',zoranl,slianl,snoanl,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) then -! call qcmxmn('plna ',plranl,slianl,snoanl,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3a ',tg3anl,slianl,snoanl,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! -! get soil temp and moisture -! - if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then - call getsmc(wetanl,len,lsoil,smcanl,me) - endif - call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - if(fnstca(1:8).eq.' ') then - call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) - endif - call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('veta ',vetanl,slianl,snoanl,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sota ',sotanl,slianl,snoanl,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l]---------------------------------------------------------------------- - call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxa ',vmxanl,slianl,snoanl,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpa ',slpanl,slianl,snoanl,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absa ',absanl,slianl,snoanl,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ---------------------------------------------------------------------------- -! -! monitoring prints -! - if (monanl) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of time and space interpolated analysis' - print *,' ' -! call count(slianl,snoanl,len) - print *,' ' - call monitr('tsfanl',tsfanl,slianl,snoanl,len) - call monitr('albanl',albanl,slianl,snoanl,len) - call monitr('aisanl',aisanl,slianl,snoanl,len) - call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('scvanl',scvanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - endif - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) -! if (gaus) then - call monitr('cvaanl',cvanl ,slianl,snoanl,len) - call monitr('cvbanl',cvbanl,slianl,snoanl,len) - call monitr('cvtanl',cvtanl,slianl,snoanl,len) -! endif - call monitr('slianl',slianl,slianl,snoanl,len) -! call monitr('plranl',plranl,slianl,snoanl,len) - call monitr('orog ',orog ,slianl,snoanl,len) - call monitr('veganl',veganl,slianl,snoanl,len) - call monitr('vetanl',vetanl,slianl,snoanl,len) - call monitr('sotanl',sotanl,slianl,snoanl,len) -!cwu [+2l] add sih, sic - call monitr('sihanl',sihanl,slianl,snoanl,len) - call monitr('sicanl',sicanl,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnanl',vmnanl,slianl,snoanl,len) - call monitr('vmxanl',vmxanl,slianl,snoanl,len) - call monitr('slpanl',slpanl,slianl,snoanl,len) - call monitr('absanl',absanl,slianl,snoanl,len) - endif - - endif -! -! read in forecast fields if needed -! - if (me .eq. 0) then - write(6,*) '==============' - write(6,*) ' fcst guess' - write(6,*) '==============' - endif -! - percrit=critp2 -! - if(deads) then -! -! fill in guess array with analysis if dead start. -! - percrit=critp3 - if (me .eq. 0) write(6,*) 'this run is dead start run' - call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs,vetfcs,sotfcs,alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl,vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & len,lsoil) - if(sig1t(1).ne.0.) then - call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, - & tsfimx) - do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - else - percrit=critp2 -! -! make reverse angulation correction to tsf -! make reverse orography correction to tg3 -! - if (use_ufo) then - orogd = orog - orog_uf -! -! The tiled version of the substrate temperature is properly -! adjusted to the terrain. Only invoke when using the old -! global tg3 grib file. -! - if ( index(fntg3c, "tileX.nc") == 0) then ! global file - ztsfc = 1.0 - call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) - endif - ztsfc = 0. - call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) - else - ztsfc = 0. - call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) - endif - -!clu [+12l] -------------------------------------------------------------- -! -! compute soil moisture liquid-to-total ratio over land -! - do j=1, lsoil - do i=1, len - if(smcfcs(i,j) .ne. 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo - enddo -!clu ----------------------------------------------------------------------- -! - if(lqcbgs .and. irtacn .eq. 0) then - call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmask,albomx,len) - do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 - enddo - kqcm=1 - call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albf ',albfcs(1,kk),slifcs,snofcs,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then - call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorf ',zorfcs,slifcs,snofcs,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) -! call qcmxmn('plnf ',plrfcs,slifcs,snofcs,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('tg3f ',tg3fcs,slifcs,snofcs,icefl1, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, - & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] --------------------------------------------------------------- - call qcmxmn('sihf ',sihfcs,slifcs,snofcs,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetf ',vetfcs,slifcs,snofcs,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotf ',sotfcs,slifcs,snofcs,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) - -!clu [+16l] --------------------------------------------------------------- - call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxf ',vmxfcs,slifcs,snofcs,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpf ',slpfcs,slifcs,snofcs,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absf ',absfcs,slifcs,snofcs,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu ----------------------------------------------------------------------- - endif - endif -! - if (monfcs) then - if (me .eq. 0) then - print *,' ' - print *,'monitor of guess' - print *,' ' -! call count(slifcs,snofcs,len) - print *,' ' - call monitr('tsffcs',tsffcs,slifcs,snofcs,len) - call monitr('albfcs',albfcs,slifcs,snofcs,len) - call monitr('aisfcs',aisfcs,slifcs,snofcs,len) - call monitr('snofcs',snofcs,slifcs,snofcs,len) - call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) - call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) - call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) - call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) -!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if(lsoil.gt.2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) - endif - call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) - call monitr('zorfcs',zorfcs,slifcs,snofcs,len) -! if (gaus) then - call monitr('cvafcs',cvfcs ,slifcs,snofcs,len) - call monitr('cvbfcs',cvbfcs,slifcs,snofcs,len) - call monitr('cvtfcs',cvtfcs,slifcs,snofcs,len) -! endif - call monitr('slifcs',slifcs,slifcs,snofcs,len) -! call monitr('plrfcs',plrfcs,slifcs,snofcs,len) - call monitr('orog ',orog ,slifcs,snofcs,len) - call monitr('vegfcs',vegfcs,slifcs,snofcs,len) - call monitr('vetfcs',vetfcs,slifcs,snofcs,len) - call monitr('sotfcs',sotfcs,slifcs,snofcs,len) -!cwu [+2l] add sih, sic - call monitr('sihfcs',sihfcs,slifcs,snofcs,len) - call monitr('sicfcs',sicfcs,slifcs,snofcs,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnfcs',vmnfcs,slifcs,snofcs,len) - call monitr('vmxfcs',vmxfcs,slifcs,snofcs,len) - call monitr('slpfcs',slpfcs,slifcs,snofcs,len) - call monitr('absfcs',absfcs,slifcs,snofcs,len) - endif - endif -! -!... update annual cycle in the sst guess.. -! -! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) -! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) - - if (fh-deltsfc > -0.001 ) then - do i=1,len - if(slianl(i) == 0.0) then - tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i)) - endif - enddo - endif -! -! quality control analysis using forecast guess -! - call qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi,len,lsoil, - & snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx,me) -! -! blend climatology and predicted fields -! - if(me .eq. 0) then - write(6,*) '==============' - write(6,*) ' merging' - write(6,*) '==============' - endif -! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) -! - percrit=critp3 -! -! merge analysis and forecast. note tg3, ais are not merged -! - call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, - & irtvet,irtsot,irtalf,landice,me) - - call setzro(snoanl,epssno,len) - -! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) -! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) - -! -! new ice/melted ice -! - call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew, aislim, sihanl & sicanl - & sihnew,aislim,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albomx,snoomx,zoromx,smcomx,smcimx, -!cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified -! & tsfomn,tsfimx,albimx,zorimx,tgice, - & tsfomn,tsfimx,albimn,zorimx,tgice, - & rla,rlo,me) - -! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) -! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) -! -! set tsfc to tsnow over snow -! - call snosfc(snoanl,tsfanl,tsfsmx,len,me) -! - do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 - enddo - kqcm=0 - call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, - & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, - & snojmx,snojmn,snosmx,snosmn,epssno, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('tsfm ',tsfanl,slianl,snoanl,icefl2, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, - & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, - & rla,rlo,len,kqcm,percrit,lgchek,me) - do kk = 1, 4 - call qcmxmn('albm ',albanl(1,kk),slianl,snoanl,icefl1, - & alblmx,alblmn,albomx,albomn,albimx,albimn, - & albjmx,albjmn,albsmx,albsmn,epsalb, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then - call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, - & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, - & wetjmx,wetjmn,wetsmx,wetsmn,epswet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('zorm ',zoranl,slianl,snoanl,icefl1, - & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, - & zorjmx,zorjmn,zorsmx,zorsmn,epszor, - & rla,rlo,len,kqcm,percrit,lgchek,me) -! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) -! & then -! call qcmxmn('plntm ',plranl,slianl,snoanl,icefl1, -! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, -! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, -! & rla,rlo,len,kqcm,percrit,lgchek,me) -! endif - call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif - kqcm=1 - call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, - & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, - & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vetm ',vetanl,slianl,snoanl,icefl1, - & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, - & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sotm ',sotanl,slianl,snoanl,icefl1, - & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, - & sotjmx,sotjmn,sotsmx,sotsmn,epssot, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!cwu [+8l] add sih, sic, - call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, - & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, - & sihjmx,sihjmn,sihsmx,sihsmn,epssih, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+16l] add vmn, vmx, slp, abs - call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, - & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, - & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('vmxm ',vmxanl,slianl,snoanl,icefl1, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, - & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('slpm ',slpanl,slianl,snoanl,icefl1, - & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, - & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('absm ',absanl,slianl,snoanl,icefl1, - & abslmx,abslmn,absomx,absomn,absimx,absimn, - & absjmx,absjmn,abssmx,abssmn,epsabs, - & rla,rlo,len,kqcm,percrit,lgchek,me) - -! - if(me .eq. 0) then - write(6,*) '==============' - write(6,*) 'final results' - write(6,*) '==============' - endif -! -! foreward correction to tg3 and tsf at the last stage -! -! if(lprnt) print *,' tsfbc=',tsfanl(iprnt) - if (use_ufo) then -! -! The tiled version of the substrate temperature is properly -! adjusted to the terrain. Only invoke when using the old -! global tg3 grib file. -! - if ( index(fntg3c, "tileX.nc") == 0) then ! global file - ztsfc = 1. - call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) - endif - ztsfc = 0. - call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) - else - ztsfc = 0. - call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) - endif -! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) -! -! check the final merged product -! - if (monmer) then - if(me .eq. 0) then - print *,' ' - print *,'monitor of updated surface fields' - print *,' (includes angulation correction)' - print *,' ' -! call count(slianl,snoanl,len) - print *,' ' - call monitr('tsfanl',tsfanl,slianl,snoanl,len) - call monitr('albanl',albanl,slianl,snoanl,len) - call monitr('aisanl',aisanl,slianl,snoanl,len) - call monitr('snoanl',snoanl,slianl,snoanl,len) - call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) -!clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) - endif -! if (gaus) then - call monitr('cvaanl',cvanl ,slianl,snoanl,len) - call monitr('cvbanl',cvbanl,slianl,snoanl,len) - call monitr('cvtanl',cvtanl,slianl,snoanl,len) -! endif - call monitr('slianl',slianl,slianl,snoanl,len) -! call monitr('plranl',plranl,slianl,snoanl,len) - call monitr('orog ',orog ,slianl,snoanl,len) - call monitr('cnpanl',cnpanl,slianl,snoanl,len) - call monitr('veganl',veganl,slianl,snoanl,len) - call monitr('vetanl',vetanl,slianl,snoanl,len) - call monitr('sotanl',sotanl,slianl,snoanl,len) -!cwu [+2l] add sih, sic, - call monitr('sihanl',sihanl,slianl,snoanl,len) - call monitr('sicanl',sicanl,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmnanl',vmnanl,slianl,snoanl,len) - call monitr('vmxanl',vmxanl,slianl,snoanl,len) - call monitr('slpanl',slpanl,slianl,snoanl,len) - call monitr('absanl',absanl,slianl,snoanl,len) - endif - endif -! - if (mondif) then - do i=1,len - tsffcs(i) = tsfanl(i) - tsffcs(i) - snofcs(i) = snoanl(i) - snofcs(i) - tg3fcs(i) = tg3anl(i) - tg3fcs(i) - zorfcs(i) = zoranl(i) - zorfcs(i) -! plrfcs(i) = plranl(i) - plrfcs(i) -! albfcs(i) = albanl(i) - albfcs(i) - slifcs(i) = slianl(i) - slifcs(i) - aisfcs(i) = aisanl(i) - aisfcs(i) - cnpfcs(i) = cnpanl(i) - cnpfcs(i) - vegfcs(i) = veganl(i) - vegfcs(i) - vetfcs(i) = vetanl(i) - vetfcs(i) - sotfcs(i) = sotanl(i) - sotfcs(i) -!clu [+2l] add sih, sic - sihfcs(i) = sihanl(i) - sihfcs(i) - sicfcs(i) = sicanl(i) - sicfcs(i) -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmnfcs(i) - vmxfcs(i) = vmxanl(i) - vmxfcs(i) - slpfcs(i) = slpanl(i) - slpfcs(i) - absfcs(i) = absanl(i) - absfcs(i) - enddo - do j = 1,lsoil - do i = 1,len - smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) - stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) - enddo - enddo - do j = 1,4 - do i = 1,len - albfcs(i,j) = albanl(i,j) - albfcs(i,j) - enddo - enddo -! -! monitoring prints -! - if(me .eq. 0) then - print *,' ' - print *,'monitor of difference' - print *,' (includes angulation correction)' - print *,' ' - call monitr('tsfdif',tsffcs,slianl,snoanl,len) - call monitr('albdif',albfcs,slianl,snoanl,len) - call monitr('albdif1',albfcs,slianl,snoanl,len) - call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) - call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) - call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) - call monitr('aisdif',aisfcs,slianl,snoanl,len) - call monitr('snodif',snofcs,slianl,snoanl,len) - call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) - call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) - call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) - call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) -!clu [+4l] add smcfcs(3:4) and stc(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) - endif - call monitr('tg3dif',tg3fcs,slianl,snoanl,len) - call monitr('zordif',zorfcs,slianl,snoanl,len) -! if (gaus) then - call monitr('cvadif',cvfcs ,slianl,snoanl,len) - call monitr('cvbdif',cvbfcs,slianl,snoanl,len) - call monitr('cvtdif',cvtfcs,slianl,snoanl,len) -! endif - call monitr('slidif',slifcs,slianl,snoanl,len) -! call monitr('plrdif',plrfcs,slianl,snoanl,len) - call monitr('cnpdif',cnpfcs,slianl,snoanl,len) - call monitr('vegdif',vegfcs,slianl,snoanl,len) - call monitr('vetdif',vetfcs,slianl,snoanl,len) - call monitr('sotdif',sotfcs,slianl,snoanl,len) -!cwu [+2l] add sih, sic - call monitr('sihdif',sihfcs,slianl,snoanl,len) - call monitr('sicdif',sicfcs,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmndif',vmnfcs,slianl,snoanl,len) - call monitr('vmxdif',vmxfcs,slianl,snoanl,len) - call monitr('slpdif',slpfcs,slianl,snoanl,len) - call monitr('absdif',absfcs,slianl,snoanl,len) - endif - endif -! -! - do i=1,len - tsffcs(i) = tsfanl(i) - snofcs(i) = snoanl(i) - tg3fcs(i) = tg3anl(i) - zorfcs(i) = zoranl(i) -! plrfcs(i) = plranl(i) -! albfcs(i) = albanl(i) - slifcs(i) = slianl(i) - aisfcs(i) = aisanl(i) - cvfcs(i) = cvanl(i) - cvbfcs(i) = cvbanl(i) - cvtfcs(i) = cvtanl(i) - cnpfcs(i) = cnpanl(i) - vegfcs(i) = veganl(i) - vetfcs(i) = vetanl(i) - sotfcs(i) = sotanl(i) -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmxfcs(i) = vmxanl(i) - slpfcs(i) = slpanl(i) - absfcs(i) = absanl(i) - enddo - do j = 1,lsoil - do i = 1,len - smcfcs(i,j) = smcanl(i,j) - if (slifcs(i) .gt. 0.0) then - stcfcs(i,j) = stcanl(i,j) - else - stcfcs(i,j) = tsffcs(i) - endif - enddo - enddo - do j = 1,4 - do i = 1,len - albfcs(i,j) = albanl(i,j) - enddo - enddo - do j = 1,2 - do i = 1,len - alffcs(i,j) = alfanl(i,j) - enddo - enddo - -!cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points - crit=aislim - do i=1,len - sihfcs(i) = sihanl(i) - sitfcs(i) = tsffcs(i) - if (slifcs(i).ge.2.) then - if (sicfcs(i).gt.crit) then - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) - else - tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice - sihfcs(i) = sihnew - endif - endif - sicfcs(i) = sicanl(i) - enddo - do i=1,len - if (slifcs(i).lt.1.5) then - sihfcs(i) = 0. - sicfcs(i) = 0. - sitfcs(i) = tsffcs(i) - else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then - print *,'warning: check, slifcs and sicfcs', - & slifcs(i),sicfcs(i) - endif - enddo - -! -! ensure the consistency between slc and smc -! - do k=1, lsoil - fixratio(k) = .false. - if (fsmcl(k).lt.99999.) fixratio(k) = .true. - enddo - - if(me .eq. 0) then - print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) - endif - - do k=1, lsoil - if(fixratio(k)) then - do i = 1, len - if(swratio(i,k) .eq. -999.) then - slcfcs(i,k) = smcfcs(i,k) - else - slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) - endif - if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. - enddo - endif - enddo -! set liquid soil moisture to a flag value of 1.0 - if (landice) then - do i = 1, len - if (slifcs(i) .eq. 1.0 .and. - & nint(vetfcs(i)) == veg_type_landice) then - do k=1, lsoil - slcfcs(i,k) = 1.0 - enddo - endif - enddo - end if -! -! ensure the consistency between snwdph and sheleg -! - if(fsnol .lt. 99999.) then - if(me .eq. 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) - enddo - endif - -! sea ice model only uses the liquid equivalent depth. -! so update the physical depth only for display purposes. -! use the same 3:1 ratio used by ice model. - - do i = 1, len - if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) - enddo - - do i = 1, len - if(slifcs(i).eq.1.) then - if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then - print *,'dbgx --scale snwdph from sheleg', - + i, swdfcs(i), snofcs(i) - swdfcs(i) = 10.* snofcs(i) - endif - endif - enddo -! landice mods - impose same minimum snow depth at -! landice as noah lsm. also ensure -! lower thermal boundary condition -! and skin t is no warmer than freezing -! after adjustment to terrain. - if (landice) then - do i = 1, len - if (slifcs(i) .eq. 1.0 .and. - & nint(vetfcs(i)) == veg_type_landice) then - snofcs(i) = max(snofcs(i),100.0) ! in mm - swdfcs(i) = max(swdfcs(i),1000.0) ! in mm - tg3fcs(i) = min(tg3fcs(i),273.15) - tsffcs(i) = min(tsffcs(i),273.15) - endif - enddo - end if -! -! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) - return - end subroutine sfccycle - -!>\ingroup mod_sfcsub -!! This subroutine counts number of points for the four surface -!! conditions. - subroutine count(slimsk,sno,ijmax) - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5 - integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij -! - real (kind=kind_io8) slimsk(1),sno(1) -! -! count number of points for the four surface conditions -! - l0 = 0 - l1 = 0 - l2 = 0 - l3 = 0 - l4 = 0 - do ij=1,ijmax - if(slimsk(ij).eq.0.) l1 = l1 + 1 - if(slimsk(ij).eq.1. .and. sno(ij).le.0.) l0 = l0 + 1 - if(slimsk(ij).eq.2. .and. sno(ij).le.0.) l2 = l2 + 1 - if(slimsk(ij).eq.1. .and. sno(ij).gt.0.) l3 = l3 + 1 - if(slimsk(ij).eq.2. .and. sno(ij).gt.0.) l4 = l4 + 1 - enddo - l5 = l0 + l3 - l6 = l2 + l4 - l7 = l1 + l6 - l8 = l1 + l5 + l6 - rl0 = float(l0) / float(l8)*100. - rl3 = float(l3) / float(l8)*100. - rl1 = float(l1) / float(l8)*100. - rl2 = float(l2) / float(l8)*100. - rl4 = float(l4) / float(l8)*100. - rl5 = float(l5) / float(l8)*100. - rl6 = float(l6) / float(l8)*100. - rl7 = float(l7) / float(l8)*100. - print *,'1) no. of not snow-covered land points ',l0,' ',rl0,' ' - print *,'2) no. of snow covered land points ',l3,' ',rl3,' ' - print *,'3) no. of open sea points ',l1,' ',rl1,' ' - print *,'4) no. of not snow-covered seaice points ',l2,' ',rl2,' ' - print *,'5) no. of snow covered sea ice points ',l4,' ',rl4,' ' - print *,' ' - print *,'6) no. of land points ',l5,' ',rl5,' ' - print *,'7) no. sea points (including sea ice) ',l7,' ',rl7,' ' - print *,' (no. of sea ice points) (',l6,')',' ',rl6,' ' - print *,' ' - print *,'9) no. of total grid points ',l8 -! print *,' ' -! print *,' ' - -! -! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) - return - end - -!>\ingroup mod_sfcsub - subroutine monitr(lfld,fld,slimsk,sno,ijmax) - use machine , only : kind_io8,kind_io4 - implicit none - integer ij,n,ijmax -! - real (kind=kind_io8) fld(ijmax), slimsk(ijmax),sno(ijmax) -! - real (kind=kind_io8) rmax(5),rmin(5) - character(len=*) lfld -! -! find max/min -! - do n=1,5 - rmax(n) = -9.e20 - rmin(n) = 9.e20 - enddo -! - do ij=1,ijmax - if(slimsk(ij).eq.0.) then - rmax(1) = max(rmax(1), fld(ij)) - rmin(1) = min(rmin(1), fld(ij)) - elseif(slimsk(ij).eq.1.) then - if(sno(ij).le.0.) then - rmax(2) = max(rmax(2), fld(ij)) - rmin(2) = min(rmin(2), fld(ij)) - else - rmax(4) = max(rmax(4), fld(ij)) - rmin(4) = min(rmin(4), fld(ij)) - endif - else - if(sno(ij).le.0.) then - rmax(3) = max(rmax(3), fld(ij)) - rmin(3) = min(rmin(3), fld(ij)) - else - rmax(5) = max(rmax(5), fld(ij)) - rmin(5) = min(rmin(5), fld(ij)) - endif - endif - enddo -! - print 100,lfld - print 101,rmax(1),rmin(1) - print 102,rmax(2),rmin(2), rmax(4), rmin(4) - print 103,rmax(3),rmin(3), rmax(5), rmin(5) -! -! print 102,rmax(2),rmin(2) -! print 103,rmax(3),rmin(3) -! print 104,rmax(4),rmin(4) -! print 105,rmax(5),rmin(5) - 100 format('0 *** ',a8,' ***') - 101 format(' open sea ......... max=',e12.4,' min=',e12.4) - 102 format(' land nosnow/snow .. max=',e12.4,' min=',e12.4 - &, ' max=',e12.4,' min=',e12.4) - 103 format(' seaice nosnow/snow max=',e12.4,' min=',e12.4 - &, ' max=',e12.4,' min=',e12.4) -! -! 100 format('0',2x,'*** ',a8,' ***') -! 102 format(2x,' land without snow ..... max=',e12.4,' min=',e12.4) -! 103 format(2x,' seaice without snow ... max=',e12.4,' min=',e12.4) -! 104 format(2x,' land with snow ........ max=',e12.4,' min=',e12.4) -! 105 format(2x,' sea ice with snow ..... max=',e12.4,' min=',e12.4) -! - return - end - -!>\ingroup mod_sfcsub -!! This subroutine figures out the day of the year given imo and idy. - subroutine dayoyr(iyr,imo,idy,ldy) - implicit none - integer ldy,i,idy,iyr,imo -! -! this routine figures out the day of the year given imo and idy -! - integer month(13) - data month/0,31,28,31,30,31,30,31,31,30,31,30,31/ - if(mod(iyr,4).eq.0) month(3) = 29 - ldy = idy - do i = 1, imo - ldy = ldy + month(i) - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, - & kpds5,slmskh,gausm,blnmsk,bltmsk,me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata, xdata, ydata - implicit none - integer kpds5,me,i,imsk,jmsk,lugb -! - character*500 fnmskh -! - real (kind=kind_io8) slmskh(mdata) - logical gausm - real (kind=kind_io8) blnmsk,bltmsk -! - imsk = xdata - jmsk = ydata - - if (me .eq. 0) then - write(6,*)' imsk=',imsk,' jmsk=',jmsk,' xdata=',xdata,' ydata=' - &, ydata - endif - - call fixrdg(lugb,imsk,jmsk,fnmskh, - & kpds5,slmskh,gausm,blnmsk,bltmsk,me) - -! print *,'in sfc_sub, aft fixrdg,slmskh=',maxval(slmskh), -! & minval(slmskh),'mdata=',mdata,'imsk*jmsk=',imsk*jmsk - - do i=1,imsk*jmsk - slmskh(i) = nint(slmskh(i)) - enddo -! - return - end - -!>\ingroup mod_sfcsub - subroutine fixrdg(lugb,idim,jdim,fngrib, - & kpds5,gdata,gaus,blno,blto,me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb, - & iret, me,kpds5,kdata,i,w3kindreal,w3kindint -! - character*(*) fngrib -! - real (kind=kind_io8) gdata(idim*jdim) - logical gaus - real (kind=kind_io8) blno,blto - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) -! - logical*1, allocatable :: lbms(:) -! - integer kpds(200),kgds(200) - integer jpds(200),jgds(200), kpds0(200) -! - allocate(data8(1:idim*jdim)) - allocate(lbms(1:mdata)) - kpds = 0 - kgds = 0 - jpds = 0 - jgds = 0 - kpds0 = 0 -! -! if(me .eq. 0) then -! write(6,*) ' ' -! write(6,*) '************************************************' -! endif -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb - lugi = 0 - lskip = -1 - n = 0 - jpds = -1 - jgds = -1 - jpds(5) = kpds5 - kpds = jpds -! - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) -! - if(me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif -! - kpds0=jpds - kpds0(4)=-1 - kpds0(18)=-1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if (iret == 99) write(6,*) ' field not found.' - call abort - endif -! - jpds = kpds0 - lskip = -1 - kdata=idim*jdim - call w3kind(w3kindreal,w3kindint) - if (w3kindreal == 8) then - call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - else if (w3kindreal == 4) then - allocate(data4(1:idim*jdim)) - call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - else - write(0,*)' Invalid w3kindreal --- aborting' - call abort - endif -! - if(jret == 0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - idim = kgds(2) - jdim = kgds(3) - gaus = kgds(1).eq.4 - blno = kgds(5)*1.d-3 - blto = kgds(4)*1.d-3 - gdata(1:idim*jdim) = data8(1:idim*jdim) - if (me == 0) write(6,*) 'idim,jdim=',idim,jdim - &, ' gaus=',gaus,' blno=',blno,' blto=',blto - else - if (me ==. 0) write(6,*) 'idim,jdim=',idim,jdim - &, ' gaus=',gaus,' blno=',blno,' blto=',blto - write(6,*) ' error in getgb : jret=',jret - write(6,*) ' kpds(13)=',kpds(13),' kpds(15)=',kpds(15) - call abort - endif -! - deallocate(data8) - deallocate(lbms) - return - end - -!>\ingroup mod_sfcsub -!! This subroutine get area of the grib record. - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr - &, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer j,me,kgds11 - real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat -! -! get area of the grib record -! - integer kgds(22) - logical ijordr -! - if (me .eq. 0) then - write(6,*) ' kgds( 1-12)=',(kgds(j),j= 1,12) - write(6,*) ' kgds(13-22)=',(kgds(j),j=13,22) - endif -! - if(kgds(1).eq.0) then ! lat/lon grid -! - if (me .eq. 0) write(6,*) 'lat/lon grid' - dlat = float(kgds(10)) * 0.001 - dlon = float(kgds( 9)) * 0.001 - f0lon = float(kgds(5)) * 0.001 - f0lat = float(kgds(4)) * 0.001 - kgds11 = kgds(11) - if(kgds11.ge.128) then - wlon = f0lon - dlon*(kgds(2)-1) - elon = f0lon - if(dlon*kgds(2).gt.359.99) then - wlon =f0lon - dlon*kgds(2) - endif - dlon = -dlon - kgds11 = kgds11 - 128 - else - wlon = f0lon - elon = f0lon + dlon*(kgds(2)-1) - if(dlon*kgds(2).gt.359.99) then - elon = f0lon + dlon*kgds(2) - endif - endif - if(kgds11.ge.64) then - rnlat = f0lat + dlat*(kgds(3)-1) - rslat = f0lat - kgds11 = kgds11 - 64 - else - rnlat = f0lat - rslat = f0lat - dlat*(kgds(3)-1) - dlat = -dlat - endif - if(kgds11.ge.32) then - ijordr = .false. - else - ijordr = .true. - endif - - if(wlon.gt.180.) wlon = wlon - 360. - if(elon.gt.180.) elon = elon - 360. - wlon = nint(wlon*1000.) * 0.001 - elon = nint(elon*1000.) * 0.001 - rslat = nint(rslat*1000.) * 0.001 - rnlat = nint(rnlat*1000.) * 0.001 - return -! - elseif(kgds(1).eq.1) then ! mercator projection - write(6,*) 'mercator grid' - write(6,*) 'cannot process' - call abort -! - elseif(kgds(1).eq.2) then ! gnomonic projection - write(6,*) 'gnomonic grid' - write(6,*) 'error!! gnomonic projection not coded' - call abort -! - elseif(kgds(1).eq.3) then ! lambert conformal - write(6,*) 'lambert conformal' - write(6,*) 'cannot process' - call abort - elseif(kgds(1).eq.4) then ! gaussian grid -! - if (me .eq. 0) write(6,*) 'gaussian grid' - dlat = 99. - dlon = float(kgds( 9)) / 1000.0 - f0lon = float(kgds(5)) / 1000.0 - f0lat = 99. - kgds11 = kgds(11) - if(kgds11.ge.128) then - wlon = f0lon - elon = f0lon - if(dlon*kgds(2).gt.359.99) then - wlon = f0lon - dlon*kgds(2) - endif - dlon = -dlon - kgds11 = kgds11-128 - else - wlon = f0lon - elon = f0lon + dlon*(kgds(2)-1) - if(dlon*kgds(2).gt.359.99) then - elon = f0lon + dlon*kgds(2) - endif - endif - if(kgds11.ge.64) then - rnlat = 99. - rslat = 99. - kgds11 = kgds11 - 64 - else - rnlat = 99. - rslat = 99. - dlat = -99. - endif - if(kgds11.ge.32) then - ijordr = .false. - else - ijordr = .true. - endif - return -! - elseif(kgds(1).eq.5) then ! polar strereographic - write(6,*) 'polar stereographic grid' - write(6,*) 'cannot process' - call abort - return -! - elseif(kgds(1).eq.13) then ! oblique lambert conformal - write(6,*) 'oblique lambert conformal grid' - write(6,*) 'cannot process' - call abort -! - elseif(kgds(1).eq.50) then ! spherical coefficient - write(6,*) 'spherical coefficient' - write(6,*) 'cannot process' - call abort - return -! - elseif(kgds(1).eq.90) then ! space view perspective -! (orthographic grid) - write(6,*) 'space view perspective grid' - write(6,*) 'cannot process' - call abort - return -! - else ! unknown projection. abort. - write(6,*) 'error!! unknown map projection' - write(6,*) 'kgds(1)=',kgds(1) - print *,'error!! unknown map projection' - print *,'kgds(1)=',kgds(1) - call abort - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine subst(data,imax,jmax,dlon,dlat,ijordr) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,ii,jj,jmax,imax,iret - real (kind=kind_io8) dlat,dlon -! - logical ijordr -! - real (kind=kind_io8) data(imax,jmax) - real (kind=kind_io8), allocatable :: work(:,:) -! - if(.not.ijordr.or. - & (ijordr.and.(dlat.gt.0..or.dlon.lt.0.))) then - allocate (work(imax,jmax)) - - if(.not.ijordr) then - do j=1,jmax - do i=1,imax - work(i,j) = data(j,i) - enddo - enddo - else - do j=1,jmax - do i=1,imax - work(i,j) = data(i,j) - enddo - enddo - endif - if (dlat > 0.0) then - if (dlon > 0.0) then - do j=1,jmax - jj = jmax - j + 1 - do i=1,imax - data(i,jj) = work(i,j) - enddo - enddo - else - do i=1,imax - data(imax-i+1,jj) = work(i,j) - enddo - endif - else - if (dlon > 0.0) then - do j=1,jmax - do i=1,imax - data(i,j) = work(i,j) - enddo - enddo - else - do j=1,jmax - do i=1,imax - data(imax-i+1,j) = work(i,j) - enddo - enddo - endif - endif - deallocate (work, stat=iret) - endif - return - end - -!>\ingroup mod_sfcsub -!! This subroutine conducts interpolation from lat/lon to Gaussian -!! grid to other lat/lon grid. - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, - & gauout,len,lmask,rslmsk,slmask - &, outlat, outlon,me) - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, - & wi1j2,wi2j1,rlat,rlon,aphi, - & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, - & ii,i1,i2,kmami,it - integer nx,kxs,kxt - integer, allocatable, save :: imxnx(:) - integer, allocatable :: ifill(:) -! -! interpolation from lat/lon or gaussian grid to other lat/lon grid -! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), - & slmask(len) - real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) -! - real (kind=kind_io8) rinlat(jmxin), rinlon(imxin) - integer iindx1(len), iindx2(len) - integer jindx1(len), jindx2(len) - real (kind=kind_io8) ddx(len), ddy(len), wrk(len) -! - logical lmask -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, len_thread, i1_t, i2_t - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - if (.not. allocated(imxnx)) allocate (imxnx(num_threads)) - endif -! -! if (me == 0) print *,' num_threads =',num_threads,' me=',me -! -! if(me .eq. 0) then -! print *,'rlon=',rlon,' me=',me -! print *,'rlat=',rlat,' me=',me,' imxin=',imxin,' jmxin=',jmxin -! endif -! -! do j=1,jmxin -! if(rlat.gt.0.) then -! rinlat(j) = rlat - float(j-1)*dlain -! else -! rinlat(j) = rlat + float(j-1)*dlain -! endif -! enddo -! -! if (me .eq. 0) then -! print *,'rinlat=' -! print *,(rinlat(j),j=1,jmxin) -! print *,'rinlon=' -! print *,(rinlon(i),i=1,imxin) -! -! print *,'outlat=' -! print *,(outlat(j),j=1,len) -! print *,(outlon(j),j=1,len) -! endif -! -! do i=1,imxin -! rinlon(i) = rlon + float(i-1)*dloin -! enddo -! -! print *,'rinlon=' -! print *,(rinlon(i),i=1,imxin) -! - len_thread_m = (len+num_threads-1) / num_threads - - if (inttyp /=1) allocate (ifill(num_threads)) -! -!$omp parallel do default(none) -!$omp+private(i1_t,i2_t,len_thread,it,i,ii,i1,i2) -!$omp+private(j,j1,j2,jq,ix,jy,nx,kxs,kxt,kmami) -!$omp+private(alamd,denom,rnume,aphi,x,y,wsum,wsumiv,sum1,sum2) -!$omp+private(sum3,sum4,wi1j1,wi2j1,wi1j2,wi2j2,wei1,wei2,wei3,wei4) -!$omp+private(sumn,sums) -!$omp+shared(imxin,jmxin,ifill) -!$omp+shared(outlon,outlat,wrk,iindx1,rinlon,jindx1,rinlat,ddx,ddy) -!$omp+shared(rlon,rlat,regin,gauout,imxnx) -!$omp+private(tem) -!$omp+shared(num_threads,len_thread_m,len,lmask,iindx2,jindx2,rslmsk) -!$omp+shared(inttyp,me,slmask) -! - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) - len_thread = i2_t-i1_t+1 -! -! find i-index for interpolation -! - do i=i1_t, i2_t - alamd = outlon(i) - if (alamd .lt. rlon) alamd = alamd + 360.0 - if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 - wrk(i) = alamd - iindx1(i) = imxin - enddo - do i=i1_t,i2_t - do ii=1,imxin - if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii - enddo - enddo - do i=i1_t,i2_t - i1 = iindx1(i) - if (i1 .lt. 1) i1 = imxin - i2 = i1 + 1 - if (i2 .gt. imxin) i2 = 1 - iindx1(i) = i1 - iindx2(i) = i2 - denom = rinlon(i2) - rinlon(i1) - if(denom.lt.0.) denom = denom + 360. - rnume = wrk(i) - rinlon(i1) - if(rnume.lt.0.) rnume = rnume + 360. - ddx(i) = rnume / denom - enddo -! -! find j-index for interplation -! - if(rlat.gt.0.) then - do j=i1_t,i2_t - jindx1(j)=0 - enddo - do jx=1,jmxin - do j=i1_t,i2_t - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=i1_t,i2_t - jq = jindx1(j) - aphi=outlat(j) - if(jq.ge.1 .and. jq .lt. jmxin) then - j2=jq+1 - j1=jq - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 0) then - j2=1 - j1=1 - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - else - do j=i1_t,i2_t - jindx1(j) = jmxin+1 - enddo - do jx=jmxin,1,-1 - do j=i1_t,i2_t - if(outlat(j).le.rinlat(jx)) jindx1(j) = jx - enddo - enddo - do j=i1_t,i2_t - jq = jindx1(j) - aphi=outlat(j) - if(jq.gt.1 .and. jq .le. jmxin) then - j2=jq - j1=jq-1 - ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) - elseif (jq .eq. 1) then - j2=1 - j1=1 - if(abs(-90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - else - j2=jmxin - j1=jmxin - if(abs(90.-rinlat(j1)).gt.0.001) then - ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) - else - ddy(j)=0.0 - endif - endif - jindx1(j)=j1 - jindx2(j)=j2 - enddo - endif -! -! if (me .eq. 0 .and. inttyp .eq. 1) then -! print *,'la2ga' -! print *,'iindx1' -! print *,(iindx1(n),n=1,len) -! print *,'iindx2' -! print *,(iindx2(n),n=1,len) -! print *,'jindx1' -! print *,(jindx1(n),n=1,len) -! print *,'jindx2' -! print *,(jindx2(n),n=1,len) -! print *,'ddy' -! print *,(ddy(n),n=1,len) -! print *,'ddx' -! print *,(ddx(n),n=1,len) -! endif -! - sum1 = 0. - sum2 = 0. - sum3 = 0. - sum4 = 0. - if (lmask) then - wei1 = 0. - wei2 = 0. - wei3 = 0. - wei4 = 0. - do i=1,imxin - sum1 = sum1 + regin(i,1) * rslmsk(i,1) - sum2 = sum2 + regin(i,jmxin) * rslmsk(i,jmxin) - wei1 = wei1 + rslmsk(i,1) - wei2 = wei2 + rslmsk(i,jmxin) -! - sum3 = sum3 + regin(i,1) * (1.0-rslmsk(i,1)) - sum4 = sum4 + regin(i,jmxin) * (1.0-rslmsk(i,jmxin)) - wei3 = wei3 + (1.0-rslmsk(i,1)) - wei4 = wei4 + (1.0-rslmsk(i,jmxin)) - enddo -! - if(wei1.gt.0.) then - sum1 = sum1 / wei1 - else - sum1 = 0. - endif - if(wei2.gt.0.) then - sum2 = sum2 / wei2 - else - sum2 = 0. - endif - if(wei3.gt.0.) then - sum3 = sum3 / wei3 - else - sum3 = 0. - endif - if(wei4.gt.0.) then - sum4 = sum4 / wei4 - else - sum4 = 0. - endif - else - do i=1,imxin - sum1 = sum1 + regin(i,1) - sum2 = sum2 + regin(i,jmxin) - enddo - sum1 = sum1 / imxin - sum2 = sum2 / imxin - sum3 = sum1 - sum4 = sum2 - endif -! -! print *,' sum1=',sum1,' sum2=',sum2 -! *,' sum3=',sum3,' sum4=',sum4 -! print *,' rslmsk=',(rslmsk(i,1),i=1,imxin) -! print *,' slmask=',(slmask(i),i=1,imxout) -! *,' j1=',jindx1(1),' j2=',jindx2(1) -! -! -! inttyp=1 take the closest point value -! - if(inttyp.eq.1) then - - do i=i1_t,i2_t - jy = jindx1(i) - if(ddy(i) .ge. 0.5) jy = jindx2(i) - ix = iindx1(i) - if(ddx(i) .ge. 0.5) ix = iindx2(i) -! -!cggg start -! - if (.not. lmask) then - - gauout(i) = regin(ix,jy) - - else - - if(slmask(i).eq.rslmsk(ix,jy)) then - - gauout(i) = regin(ix,jy) - - else - - i1 = ix - j1 = jy - -! spiral around until matching mask is found. - do nx=1,jmxin*imxin/2 - kxs=sqrt(4*nx-2.5) - kxt=nx-int(kxs**2/4+1) - select case(mod(kxs,4)) - case(1) - ix=i1-kxs/4+kxt - jx=j1-kxs/4 - case(2) - ix=i1+1+kxs/4 - jx=j1-kxs/4+kxt - case(3) - ix=i1+1+kxs/4-kxt - jx=j1+1+kxs/4 - case default - ix=i1-kxs/4 - jx=j1+kxs/4-kxt - end select - if(jx.lt.1) then - ix=ix+imxin/2 - jx=2-jx - elseif(jx.gt.jmxin) then - ix=ix+imxin/2 - jx=2*jmxin-jx - endif - ix=modulo(ix-1,imxin)+1 - if(slmask(i).eq.rslmsk(ix,jx)) then - gauout(i) = regin(ix,jx) - go to 81 - endif - enddo - -!cggg here, set the gauout value to be 0, and let's sarah's land -!cggg routine assign a default. - - if (num_threads == 1) then - print*,'no matching mask found ',i,i1,j1,ix,jx - print*,'set to default value.' - endif - gauout(i) = 0.0 - - - 81 continue - - end if - - end if - -!cggg end - - enddo -! kmami=1 -! if (me == 0 .and. num_threads == 1) -! & call maxmin(gauout(i1_t),len_thread,kmami) - else ! nearest neighbor interpolation - -! -! quasi-bilinear interpolation -! - ifill(it) = 0 - imxnx(it) = 0 - do i=i1_t,i2_t - y = ddy(i) - j1 = jindx1(i) - j2 = jindx2(i) - x = ddx(i) - i1 = iindx1(i) - i2 = iindx2(i) -! - wi1j1 = (1.-x) * (1.-y) - wi2j1 = x *( 1.-y) - wi1j2 = (1.-x) * y - wi2j2 = x * y -! - tem = 4.*slmask(i) - rslmsk(i1,j1) - rslmsk(i2,j1) - & - rslmsk(i1,j2) - rslmsk(i2,j2) - if(lmask .and. abs(tem) .gt. 0.01) then - if(slmask(i).eq.1.) then - wi1j1 = wi1j1 * rslmsk(i1,j1) - wi2j1 = wi2j1 * rslmsk(i2,j1) - wi1j2 = wi1j2 * rslmsk(i1,j2) - wi2j2 = wi2j2 * rslmsk(i2,j2) - else - wi1j1 = wi1j1 * (1.0-rslmsk(i1,j1)) - wi2j1 = wi2j1 * (1.0-rslmsk(i2,j1)) - wi1j2 = wi1j2 * (1.0-rslmsk(i1,j2)) - wi2j2 = wi2j2 * (1.0-rslmsk(i2,j2)) - endif - endif -! - wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 - wrk(i) = wsum - if(wsum.ne.0.) then - wsumiv = 1./wsum -! - if(j1.ne.j2) then - gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + - & wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) - & *wsumiv - else -! - if (rlat .gt. 0.0) then - if (slmask(i) .eq. 1.0) then - sumn = sum1 - sums = sum2 - else - sumn = sum3 - sums = sum4 - endif - if( j1 .eq. 1) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + - & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) - & * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ - & wi1j2*sums +wi2j2*sums ) - & * wsumiv - endif -! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn -! & ,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2 -! & ,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv - else - if (slmask(i) .eq. 1.0) then - sums = sum1 - sumn = sum2 - else - sums = sum3 - sumn = sum4 - endif - if( j1 .eq. 1) then - gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ - & wi1j2*sums +wi2j2*sums ) - & * wsumiv - elseif (j1 .eq. jmxin) then - gauout(i) = (wi1j1*sumn +wi2j1*sumn + - & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) - & * wsumiv - endif - endif - endif ! if j1 .ne. j2 - endif - enddo - do i=i1_t,i2_t - j1 = jindx1(i) - j2 = jindx2(i) - i1 = iindx1(i) - i2 = iindx2(i) - if(wrk(i) .eq. 0.0) then - if(.not.lmask) then - if (num_threads == 1) - & write(6,*) ' la2ga called with lmask=.true. but bad', - & ' rslmsk or slmask given' - call abort - endif - ifill(it) = ifill(it) + 1 - if(ifill(it) <= 2 ) then - if (me == 0 .and. num_threads == 1) then - write(6,*) 'i1,i2,j1,j2=',i1,i2,j1,j2 - write(6,*) 'rslmsk=',rslmsk(i1,j1),rslmsk(i1,j2), - & rslmsk(i2,j1),rslmsk(i2,j2) -! write(6,*) 'i,j=',i,j,' slmask(i)=',slmask(i) - write(6,*) 'i=',i,' slmask(i)=',slmask(i) - &, ' outlon=',outlon(i),' outlat=',outlat(i) - endif - endif -! spiral around until matching mask is found. - do nx=1,jmxin*imxin/2 - kxs=sqrt(4*nx-2.5) - kxt=nx-int(kxs**2/4+1) - select case(mod(kxs,4)) - case(1) - ix=i1-kxs/4+kxt - jx=j1-kxs/4 - case(2) - ix=i1+1+kxs/4 - jx=j1-kxs/4+kxt - case(3) - ix=i1+1+kxs/4-kxt - jx=j1+1+kxs/4 - case default - ix=i1-kxs/4 - jx=j1+kxs/4-kxt - end select - if(jx.lt.1) then - ix=ix+imxin/2 - jx=2-jx - elseif(jx.gt.jmxin) then - ix=ix+imxin/2 - jx=2*jmxin-jx - endif - ix=modulo(ix-1,imxin)+1 - if(slmask(i).eq.rslmsk(ix,jx)) then - gauout(i) = regin(ix,jx) - imxnx(it) = max(imxnx(it),nx) - go to 71 - endif - enddo -! - if (num_threads == 1) then - write(6,*) ' error!!! no filling value found in la2ga' -! write(6,*) ' i ix jx slmask(i) rslmsk ', -! & i,ix,jx,slmask(i),rslmsk(ix,jx) - endif - call abort -! - 71 continue - endif -! - enddo - endif - enddo ! end of threaded loop ................... -!$omp end parallel do -! - if(inttyp /= 1)then - ifills = 0 - do it=1,num_threads - ifills = ifills + ifill(it) - enddo - - if(ifills.gt.1) then - if (me .eq. 0) then - write(6,*) ' unable to interpolate. filled with nearest', - & ' point value at ',ifills,' points' -! & ' point value at ',ifills,' points imxnx=',imxnx(:) - endif - endif - deallocate (ifill) - endif -! -! kmami = 1 -! if (me == 0) call maxmin(gauout,len,kmami) -! - return - end subroutine la2ga - -!>\ingroup mod_sfcsub - subroutine maxmin(f,imax,kmax) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,iimin,iimax,kmax,imax,k - real (kind=kind_io8) fmin,fmax -! - real (kind=kind_io8) f(imax,kmax) -! - do k=1,kmax -! - fmax = f(1,k) - fmin = f(1,k) -! - do i=1,imax - if(fmax.le.f(i,k)) then - fmax = f(i,k) - iimax = i - endif - if(fmin.ge.f(i,k)) then - fmin = f(i,k) - iimin = i - endif - enddo -! -! write(6,100) k,fmax,iimax,fmin,iimin -! 100 format(2x,'level=',i2,' max=',e11.4,' at i=',i7, -! & ' min=',e11.4,' at i=',i7) -! - enddo -! - return - end - -!>\ingroup mod_sfcsub - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, - & aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, - & aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, -!cwu [+1l] add ()clm for sih, sic - & sihclm,sicclm, -!clu [+1l] add ()clm for vmn, vmx, slp, abs - & vmnclm,vmxclm,slpclm,absclm, - & len,lsoil) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil -! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), - & snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),scvanl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), - & snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) -!cwu [+1l] add ()clm for sih, sic - &, sihclm(len),sicclm(len) -!clu [+1l] add ()clm for vmn, vmx, slp, abs - &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) -! - do i=1,len - tsfanl(i) = tsfclm(i) ! tsf at t - tsfan2(i) = tsfcl2(i) ! tsf at t-deltsfc - wetanl(i) = wetclm(i) ! soil wetness - snoanl(i) = snoclm(i) ! snow - scvanl(i) = scvclm(i) ! snow cover - aisanl(i) = aisclm(i) ! seaice - slianl(i) = sliclm(i) ! land/sea/snow mask - zoranl(i) = zorclm(i) ! surface roughness -! plranl(i) = plrclm(i) ! maximum stomatal resistance - tg3anl(i) = tg3clm(i) ! deep soil temperature - cnpanl(i) = cnpclm(i) ! canopy water content - veganl(i) = vegclm(i) ! vegetation cover - vetanl(i) = vetclm(i) ! vegetation type - sotanl(i) = sotclm(i) ! soil type - cvanl(i) = cvclm(i) ! cv - cvbanl(i) = cvbclm(i) ! cvb - cvtanl(i) = cvtclm(i) ! cvt -!cwu [+4l] add sih, sic - sihanl(i) = sihclm(i) ! sea ice thickness - sicanl(i) = sicclm(i) ! sea ice concentration -!clu [+4l] add vmn, vmx, slp, abs - vmnanl(i) = vmnclm(i) ! min vegetation cover - vmxanl(i) = vmxclm(i) ! max vegetation cover - slpanl(i) = slpclm(i) ! slope type - absanl(i) = absclm(i) ! max snow albedo - enddo -! - do j=1,lsoil - do i=1,len - smcanl(i,j) = smcclm(i,j) ! layer soil wetness - stcanl(i,j) = stcclm(i,j) ! soil temperature - enddo - enddo - do j=1,4 - do i=1,len - albanl(i,j) = albclm(i,j) ! albedo - enddo - enddo - do j=1,2 - do i=1,len - alfanl(i,j) = alfclm(i,j) ! vegetation fraction for albedo - enddo - enddo -! - return - end - -!>\ingroup mod_sfcsub - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, -!clu [+1l] add fn()a for vmn, vmx, slp, abs - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, -!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, -!cggg snow mods end - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kprvet,kpdsot,kpdalf, -!clu [+1l] add kpd() for vmn, vmx, slp, abs - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf -!clu [+1l] add irt() for vmn, vmx, slp, abs - &, irtvmn,irtvmx,irtslp,irtabs - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me, lanom) - use machine , only : kind_io8,kind_io4 - implicit none - logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, -!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, -!cggg snow mods end - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j -!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs - &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs - real (kind=kind_io8) blto,blno,fh -! - real (kind=kind_io8) slmask(len) - real (kind=kind_io8) slmskh(imsk,jmsk) - real (kind=kind_io8) outlat(len), outlon(len) - integer kpdalb(4), kpdalf(2) -!cggg snow mods start - integer kpds(1000),kgds(1000),jpds(1000),jgds(1000) - integer lugi, lskip, lgrib, ndata -!cggg snow mods end -! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota -!clu [+1l] add fn()a for vmn, vmx, slp, abs - &, fnvmna,fnvmxa,fnslpa,fnabsa - - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & slianl(len), scvanl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), - & smcanl(len,lsoil), stcanl(len,lsoil), - & tsfan0(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - logical gaus -! -! tsf -! - irttsf = 1 - if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmask, - & iy,im,id,ih,fh,tsfanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irttsf = iret - if(iret == 1) then - write(6,*) 't surface analysis read error' - call abort - elseif(iret == -1) then - if (me == 0) then - print *,'old t surface analysis provided, indicating proper' - &, ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me == 0) print *,'t surface analysis provided.' - endif - else - if (me == 0) then -! print *,'************************************************' - print *,'no tsf analysis available. climatology used' - endif - endif -! -! tsf0 -! - if(fntsfa(1:8).ne.' ' .and. lanom) then - call fixrda(lugb,fntsfa,kpdtsf,slmask, - & iy,im,id,ih,0.,tsfan0,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - if(iret == 1) then - write(6,*) 't surface at ft=0 analysis read error' - call abort - elseif(iret == -1) then - if (me == 0) then - write(6,*) 'could not find t surface analysis at ft=0' - endif - call abort - else - print *,'t surface analysis at ft=0 found.' - endif - else - do i=1,len - tsfan0(i)=-999.9 - enddo - endif -! -! albedo -! - irtalb=0 - if(fnalba(1:8).ne.' ') then - do kk = 1, 4 - call fixrda(lugb,fnalba,kpdalb(kk),slmask, - & iy,im,id,ih,fh,albanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalb=iret - if(iret.eq.1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old albedo analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0 .and. kk .eq. 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no albedo analysis available. climatology used' - endif - endif -! -! vegetation fraction for albedo -! - irtalf=0 - if(fnalba(1:8).ne.' ') then - do kk = 1, 2 - call fixrda(lugb,fnalba,kpdalf(kk),slmask, - & iy,im,id,ih,fh,alfanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalf=iret - if(iret.eq.1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old albedo analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0 .and. kk .eq. 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegfalbedo analysis available. climatology used' - endif - endif -! -! soil wetness -! - irtwet=0 - irtsmc=0 - if(fnweta(1:8).ne.' ') then - call fixrda(lugb,fnweta,kpdwet,slmask, - & iy,im,id,ih,fh,wetanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtwet=iret - if(iret.eq.1) then - write(6,*) 'bucket wetness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old wetness analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'bucket wetness analysis provided.' - endif - elseif(fnsmca(1:8).ne.' ') then - call fixrda(lugb,fnsmca,kpdsmc,slmask, - & iy,im,id,ih,fh,smcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnsmca,kpdsmc,slmask, - & iy,im,id,ih,fh,smcanl(1,2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsmc=iret - if(iret.eq.1) then - write(6,*) 'layer soil wetness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old layer soil wetness analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'layer soil wetness analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no soil wetness analysis available. climatology used' - endif - endif -! -! read in snow depth/snow cover -! - irtscv=0 - if(fnsnoa(1:8).ne.' ') then - do i=1,len - scvanl(i)=0. - enddo -!cggg snow mods start -!cggg need to determine if the snow data is on the gaussian grid -!cggg or not. if gaussian, then data is a depth, not liq equiv -!cggg depth. if not gaussian, then data is from hua-lu's -!cggg program and is a liquid equiv. need to communicate -!cggg this to routine fixrda via the 3rd argument which is -!cggg the grib parameter id number. - call baopenr(lugb,fnsnoa,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fnsnoa) - print *,'error in opening file ',trim(fnsnoa) - call abort - endif - lugi=0 - lskip=-1 - jpds=-1 - jgds=-1 - kpds=jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - close(lugb) - if (iret .ne. 0) then - write(6,*) ' error reading header of file: ',trim(fnsnoa) - print *,'error reading header of file: ',trim(fnsnoa) - call abort - endif - if (kgds(1) == 4) then ! gaussian data is depth - call fixrda(lugb,fnsnoa,kpdsnd,slmask, - & iy,im,id,ih,fh,snoanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - snoanl=snoanl*100. ! convert from meters to liq. eq. - ! depth in mm using 10:1 ratio - else ! lat/lon data is liq equv. depth - call fixrda(lugb,fnsnoa,kpdsno,slmask, - & iy,im,id,ih,fh,snoanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -!cggg snow mods end - irtscv=iret - if(iret.eq.1) then - write(6,*) 'snow depth analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snow depth analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snow depth analysis provided.' - endif - irtsno=0 - elseif(fnscva(1:8).ne.' ') then - do i=1,len - snoanl(i)=0. - enddo - call fixrda(lugb,fnscva,kpdscv,slmask, - & iy,im,id,ih,fh,scvanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsno=iret - if(iret.eq.1) then - write(6,*) 'snow cover analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snow cover analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snow cover analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no snow/snocov analysis available. climatology used' - endif - endif -! -! sea ice mask -! - irtacn=0 - irtais=0 - if(fnacna(1:8).ne.' ') then - call fixrda(lugb,fnacna,kpdacn,slmask, - & iy,im,id,ih,fh,acnanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtacn=iret - if(iret.eq.1) then - write(6,*) 'ice concentration analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old ice concentration analysis provided', - & ' indicating proper file name is given' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'ice concentration analysis provided.' - endif - elseif(fnaisa(1:8).ne.' ') then - call fixrda(lugb,fnaisa,kpdais,slmask, - & iy,im,id,ih,fh,aisanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtais=iret - if(iret.eq.1) then - write(6,*) 'ice mask analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old ice-mask analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'ice mask analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no sea-ice analysis available. climatology used' - endif - endif -! -! surface roughness -! - irtzor=0 - if(fnzora(1:8).ne.' ') then - call fixrda(lugb,fnzora,kpdzor,slmask, - & iy,im,id,ih,fh,zoranl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtzor=iret - if(iret.eq.1) then - write(6,*) 'roughness analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old roughness analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'roughness analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no srfc roughness analysis available. climatology used' - endif - endif -! -! deep soil temperature -! - irttg3=0 - irtstc=0 - if(fntg3a(1:8).ne.' ') then - call fixrda(lugb,fntg3a,kpdtg3,slmask, - & iy,im,id,ih,fh,tg3anl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irttg3=iret - if(iret.eq.1) then - write(6,*) 'deep soil tmp analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old deep soil temp analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'deep soil tmp analysis provided.' - endif - elseif(fnstca(1:8).ne.' ') then - call fixrda(lugb,fnstca,kpdstc,slmask, - & iy,im,id,ih,fh,stcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnstca,kpdstc,slmask, - & iy,im,id,ih,fh,stcanl(1,2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtstc=iret - if(iret.eq.1) then - write(6,*) 'layer soil tmp analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old deep soil temp analysis provided', - & 'iindicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'layer soil tmp analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no deep soil temp analy available. climatology used' - endif - endif -! -! vegetation cover -! - irtveg=0 - if(fnvega(1:8).ne.' ') then - call fixrda(lugb,fnvega,kpdveg,slmask, - & iy,im,id,ih,fh,veganl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtveg=iret - if(iret.eq.1) then - write(6,*) 'vegetation cover analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old vegetation cover analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'gegetation cover analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegetation cover anly available. climatology used' - endif - endif -! -! vegetation type -! - irtvet=0 - if(fnveta(1:8).ne.' ') then - call fixrda(lugb,fnveta,kpdvet,slmask, - & iy,im,id,ih,fh,vetanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvet=iret - if(iret.eq.1) then - write(6,*) 'vegetation type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old vegetation type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'vegetation type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no vegetation type anly available. climatology used' - endif - endif -! -! soil type -! - irtsot=0 - if(fnsota(1:8).ne.' ') then - call fixrda(lugb,fnsota,kpdsot,slmask, - & iy,im,id,ih,fh,sotanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtsot=iret - if(iret.eq.1) then - write(6,*) 'soil type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old soil type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'soil type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no soil type anly available. climatology used' - endif - endif - -!clu [+120l]-------------------------------------------------------------- -! -! min vegetation cover -! - irtvmn=0 - if(fnvmna(1:8).ne.' ') then - call fixrda(lugb,fnvmna,kpdvmn,slmask, - & iy,im,id,ih,fh,vmnanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvmn=iret - if(iret.eq.1) then - write(6,*) 'shdmin analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old shdmin analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'shdmin analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no shdmin anly available. climatology used' - endif - endif - -! -! max vegetation cover -! - irtvmx=0 - if(fnvmxa(1:8).ne.' ') then - call fixrda(lugb,fnvmxa,kpdvmx,slmask, - & iy,im,id,ih,fh,vmxanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtvmx=iret - if(iret.eq.1) then - write(6,*) 'shdmax analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old shdmax analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'shdmax analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no shdmax anly available. climatology used' - endif - endif - -! -! slope type -! - irtslp=0 - if(fnslpa(1:8).ne.' ') then - call fixrda(lugb,fnslpa,kpdslp,slmask, - & iy,im,id,ih,fh,slpanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtslp=iret - if(iret.eq.1) then - write(6,*) 'slope type analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old slope type analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'slope type analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no slope type anly available. climatology used' - endif - endif - -! -! max snow albedo -! - irtabs=0 - if(fnabsa(1:8).ne.' ') then - call fixrda(lugb,fnabsa,kpdabs,slmask, - & iy,im,id,ih,fh,absanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtabs=iret - if(iret.eq.1) then - write(6,*) 'snoalb analysis read error' - call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old snoalb analysis provided', - & ' indicating proper file name is given.' - print *,' no error suspected.' - write(6,*) 'forecast guess will be used' - endif - else - if (me .eq. 0) print *,'snoalb analysis provided.' - endif - else - if (me .eq. 0) then -! print *,'************************************************' - print *,'no snoalb anly available. climatology used' - endif - endif - -!clu ---------------------------------------------------------------------- -! - return - end - -!>\ingroup mod_sfcsub - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs, vetfcs, sotfcs, alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl, vetanl, sotanl, alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & len,lsoil) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), - & zorfcs(len),albfcs(len,4),aisfcs(len), - & tg3fcs(len), - & cvfcs (len),cvbfcs(len),cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len),vegfcs(len), - & vetfcs(len),sotfcs(len),alffcs(len,2) -!cwu [+1l] add ()fcs for sih, sic - &, sihfcs(len),sicfcs(len) -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - write(6,*) ' this is a dead start run, tsfc over land is', - & ' set as lowest sigma level temperture if given.' - write(6,*) ' if not, set to climatological tsf over land is used' -! -! - do i=1,len - tsffcs(i) = tsfanl(i) ! tsf - albfcs(i,1) = albanl(i,1) ! albedo - albfcs(i,2) = albanl(i,2) ! albedo - albfcs(i,3) = albanl(i,3) ! albedo - albfcs(i,4) = albanl(i,4) ! albedo - wetfcs(i) = wetanl(i) ! soil wetness - snofcs(i) = snoanl(i) ! snow - aisfcs(i) = aisanl(i) ! seaice - slifcs(i) = slianl(i) ! land/sea/snow mask - zorfcs(i) = zoranl(i) ! surface roughness -! plrfcs(i) = plranl(i) ! maximum stomatal resistance - tg3fcs(i) = tg3anl(i) ! deep soil temperature - cnpfcs(i) = cnpanl(i) ! canopy water content - cvfcs(i) = cvanl(i) ! cv - cvbfcs(i) = cvbanl(i) ! cvb - cvtfcs(i) = cvtanl(i) ! cvt - vegfcs(i) = veganl(i) ! vegetation cover - vetfcs(i) = vetanl(i) ! vegetation type - sotfcs(i) = sotanl(i) ! soil type - alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo - alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo -!cwu [+2l] add sih, sic - sihfcs(i) = sihanl(i) ! sea ice thickness - sicfcs(i) = sicanl(i) ! sea ice concentration -!clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) ! min vegetation cover - vmxfcs(i) = vmxanl(i) ! max vegetation cover - slpfcs(i) = slpanl(i) ! slope type - absfcs(i) = absanl(i) ! max snow albedo - enddo -! - do j=1,lsoil - do i=1,len - smcfcs(i,j) = smcanl(i,j) ! layer soil wetness - stcfcs(i,j) = stcanl(i,j) ! soil temperature - enddo - enddo -! - return - end - -!>\ingroup mod_sfcsub - subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), - & slianl(len) -! -! note that smfcs comes in with the original unit (cm?) (not grib file) -! - do i = 1, len - smcfcs(i,1) = (smcfcs(i,1)/150.) * .37 + .1 - enddo - do k = 2, lsoil - do i = 1, len - smcfcs(i,k) = smcfcs(i,1) - enddo - enddo - if(lsoil.gt.2) then - do k = 3, lsoil - do i = 1, len - stcfcs(i,k) = stcfcs(i,2) - enddo - enddo - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine rof01(aisfld,len,op,crit) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) aisfld(len),crit - character*2 op -! - if(op.eq.'ge') then - do i=1,len - if(aisfld(i).ge.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'gt') then - do i=1,len - if(aisfld(i).gt.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'le') then - do i=1,len - if(aisfld(i).le.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - elseif(op.eq.'lt') then - do i=1,len - if(aisfld(i).lt.crit) then - aisfld(i)=1. - else - aisfld(i)=0. - endif - enddo - else - write(6,*) ' illegal operator in rof01. op=',op - call abort - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) rlapse,umask - real (kind=kind_io8) tsfc(len), orog(len), slmask(len) -! - do i=1,len - if(slmask(i).eq.umask) then - tsfc(i) = tsfc(i) - orog(i)*rlapse - endif - enddo - return - end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, - & glacir,snwmax,snwmin,landice,len,snoanl, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,me,len - logical, intent(in) :: landice - real (kind=kind_io8) sno,snwmax,snwmin -! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), - & snoclm(len), snoanl(len), glacir(len) -! - if (me .eq. 0) write(6,*) 'snodpth' -! -! use surface temperature to get snow depth estimate -! - do i=1,len - sno = 0.0 -! -! over land -! - if(slianl(i).eq.1.) then - if(scvanl(i).eq.1.0) then - if(tsfanl(i).lt.243.0) then - sno = snwmax - elseif(tsfanl(i).lt.273.0) then - sno = snwmin+(snwmax-snwmin)*(273.0-tsfanl(i))/30.0 - else - sno = snwmin - endif - endif -! -! if glacial points has snow in climatology, set sno to snomax -! - if (.not.landice) then - if(glacir(i).eq.1.0) then - sno = snoclm(i) - if(sno.eq.0.) sno=snwmax - endif - endif - endif -! -! over sea ice -! -! snow over sea ice is cycled as of 01/01/94.....hua-lu pan -! - if(slianl(i).eq.2.0) then - sno=snoclm(i) - if(sno.eq.0.) sno=snwmax - endif -! - snoanl(i) = sno - enddo - return - end subroutine snodpth - -!>\ingroup mod_sfcsub - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, - & irtvet,irtsot,irtalf, landice, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : veg_type_landice, soil_type_landice - implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, - & irtalb,irtsno,irttsf,irtwet,j - &, irtvmn,irtvmx,irtslp,irtabs - logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, - & cvets,calfs,deltsfc, - & csihl,csihs,csicl,csics, - & rsihl,rsihs,rsicl,rsics, - & qsihl,qsihs,qsicl,qsics - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns - &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss -! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2) - &, sihfcs(len), sicfcs(len) - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), - & wetanl(len),snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2) - &, sihanl(len),sicanl(len) - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), - & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), - & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), - & qstcl(lsoil), qstcs(lsoil) - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! -! coeeficients of blending forecast and interpolated clim -! (or analyzed) fields over sea or land(l) (not for clouds) -! 1.0 = use of forecast -! 0.0 = replace with interpolated analysis -! -! merging coefficients are defined by parameter statement in calling program -! and therefore they should not be modified in this program. -! - rtsfl = ctsfl - ralbl = calbl - ralfl = calfl - raisl = caisl - rsnol = csnol -!clu rsmcl = csmcl - rzorl = czorl - rvegl = cvegl - rvetl = cvetl - rsotl = csotl - rsihl = csihl - rsicl = csicl - rvmnl = cvmnl - rvmxl = cvmxl - rslpl = cslpl - rabsl = cabsl -! - rtsfs = ctsfs - ralbs = calbs - ralfs = calfs - raiss = caiss - rsnos = csnos -! rsmcs = csmcs - rzors = czors - rvegs = cvegs - rvets = cvets - rsots = csots - rsihs = csihs - rsics = csics - rvmns = cvmns - rvmxs = cvmxs - rslps = cslps - rabss = cabss -! - rcv = ccv - rcvb = ccvb - rcvt = ccvt - rcnp = ccnp -! - do k=1,lsoil - rsmcl(k) = csmcl(k) - rsmcs(k) = csmcs(k) - rstcl(k) = cstcl(k) - rstcs(k) = cstcs(k) - enddo - if (fh-deltsfc < -0.001 .and. irttsf == 1) then - rtsfs = 1.0 - rtsfl = 1.0 -! do k=1,lsoil -! rsmcl(k) = 1.0 -! rsmcs(k) = 1.0 -! rstcl(k) = 1.0 -! rstcs(k) = 1.0 -! enddo - endif -! -! if analysis file name is given but no matching analysis date found, -! use guess (these are flagged by irt???=1). -! - if(irttsf == -1) then - rtsfl = 1. - rtsfs = 1. - endif - if(irtalb == -1) then - ralbl = 1. - ralbs = 1. - ralfl = 1. - ralfs = 1. - endif - if(irtais == -1) then - raisl = 1. - raiss = 1. - endif - if(irtsno == -1 .or. irtscv == -1) then - rsnol = 1. - rsnos = 1. - endif - if(irtsmc == -1 .or. irtwet == -1) then -! rsmcl = 1. -! rsmcs = 1. - do k=1,lsoil - rsmcl(k) = 1. - rsmcs(k) = 1. - enddo - endif - if(irtstc.eq.-1) then - do k=1,lsoil - rstcl(k) = 1. - rstcs(k) = 1. - enddo - endif - if(irtzor == -1) then - rzorl = 1. - rzors = 1. - endif - if(irtveg == -1) then - rvegl = 1. - rvegs = 1. - endif - if(irtvet.eq.-1) then - rvetl = 1. - rvets = 1. - endif - if(irtsot == -1) then - rsotl = 1. - rsots = 1. - endif - - if(irtacn == -1) then - rsicl = 1. - rsics = 1. - endif - if(irtvmn == -1) then - rvmnl = 1. - rvmns = 1. - endif - if(irtvmx == -1) then - rvmxl = 1. - rvmxs = 1. - endif - if(irtslp == -1) then - rslpl = 1. - rslps = 1. - endif - if(irtabs == -1) then - rabsl = 1. - rabss = 1. - endif -! - if(raiss == 1. .or. irtacn == -1) then - if (me == 0) print *,'use forecast land-sea-ice mask' - do i = 1, len - aisanl(i) = aisfcs(i) - slianl(i) = slifcs(i) - enddo - endif -! - if (me == 0) then - write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl - 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) - write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs - 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',10f7.3) -! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl -! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets - endif -! - qtsfl = 1. - rtsfl - qalbl = 1. - ralbl - qalfl = 1. - ralfl - qaisl = 1. - raisl - qsnol = 1. - rsnol -! qsmcl = 1. - rsmcl - qzorl = 1. - rzorl - qvegl = 1. - rvegl - qvetl = 1. - rvetl - qsotl = 1. - rsotl - qsihl = 1. - rsihl - qsicl = 1. - rsicl - qvmnl = 1. - rvmnl - qvmxl = 1. - rvmxl - qslpl = 1. - rslpl - qabsl = 1. - rabsl -! - qtsfs = 1. - rtsfs - qalbs = 1. - ralbs - qalfs = 1. - ralfs - qaiss = 1. - raiss - qsnos = 1. - rsnos -! qsmcs = 1. - rsmcs - qzors = 1. - rzors - qvegs = 1. - rvegs - qvets = 1. - rvets - qsots = 1. - rsots - qsihs = 1. - rsihs - qsics = 1. - rsics - qvmns = 1. - rvmns - qvmxs = 1. - rvmxs - qslps = 1. - rslps - qabss = 1. - rabss -! - qcv = 1. - rcv - qcvb = 1. - rcvb - qcvt = 1. - rcvt - qcnp = 1. - rcnp -! - do k=1,lsoil - qsmcl(k) = 1. - rsmcl(k) - qsmcs(k) = 1. - rsmcs(k) - qstcl(k) = 1. - rstcl(k) - qstcs(k) = 1. - rstcs(k) - enddo -! -! merging -! - if(me .eq. 0) then - print *, 'dbgx-- csmcl:', (csmcl(k),k=1,lsoil) - print *, 'dbgx-- rsmcl:', (rsmcl(k),k=1,lsoil) - print *, 'dbgx-- csnol, csnos:',csnol,csnos - print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos - endif - -! print *, rtsfs, qtsfs, raiss , qaiss -! *, rsnos , qsnos, rzors , qzors, rvegs , qvegs -! *, rvets , qvets, rsots , qsots -! *, rcv, rcvb, rcvt, qcv, qcvb, qcvt -! *, ralbs, qalbs, ralfs, qalfs -! print *, rtsfl, qtsfl, raisl , qaisl -! *, rsnol , qsnol, rzorl , qzorl, rvegl , qvegl -! *, rvetl , qvetl, rsotl , qsotl -! *, ralbl, qalbl, ralfl, qalfl -! -! - len_thread_m = (len+num_threads-1) / num_threads - -!$omp parallel do private(i1_t,i2_t,it,i) - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets - sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots - else - vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl - sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl - endif - enddo - enddo -!$omp end parallel do -! -!$omp parallel do private(i1_t,i2_t,it,i,k) -! - do it=1,num_threads ! start of threaded loop ................... - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) -! - do i=i1_t,i2_t - if(slianl(i).eq.0.) then -!.... tsffc2 is the previous anomaly + today's climatology -! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) -! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs -! - tsfanl(i) = tsffcs(i)*rtsfs + tsfanl(i)*qtsfs -! albanl(i) = albfcs(i)*ralbs + albanl(i)*qalbs - aisanl(i) = aisfcs(i)*raiss + aisanl(i)*qaiss - snoanl(i) = snofcs(i)*rsnos + snoanl(i)*qsnos - - zoranl(i) = zorfcs(i)*rzors + zoranl(i)*qzors - veganl(i) = vegfcs(i)*rvegs + veganl(i)*qvegs - sihanl(i) = sihfcs(i)*rsihs + sihanl(i)*qsihs - sicanl(i) = sicfcs(i)*rsics + sicanl(i)*qsics - vmnanl(i) = vmnfcs(i)*rvmns + vmnanl(i)*qvmns - vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs - slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps - absanl(i) = absfcs(i)*rabss + absanl(i)*qabss - else - tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl -! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl - aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl - if(rsnol.ge.0)then - snoanl(i) = snofcs(i)*rsnol + snoanl(i)*qsnol - else ! envelope method - if(snoanl(i).ne.0)then - snoanl(i) = max(-snoanl(i)/rsnol, - & min(-snoanl(i)*rsnol, snofcs(i))) - endif - endif - zoranl(i) = zorfcs(i)*rzorl + zoranl(i)*qzorl - veganl(i) = vegfcs(i)*rvegl + veganl(i)*qvegl - vmnanl(i) = vmnfcs(i)*rvmnl + vmnanl(i)*qvmnl - vmxanl(i) = vmxfcs(i)*rvmxl + vmxanl(i)*qvmxl - slpanl(i) = slpfcs(i)*rslpl + slpanl(i)*qslpl - absanl(i) = absfcs(i)*rabsl + absanl(i)*qabsl - sihanl(i) = sihfcs(i)*rsihl + sihanl(i)*qsihl - sicanl(i) = sicfcs(i)*rsicl + sicanl(i)*qsicl - endif - - cnpanl(i) = cnpfcs(i)*rcnp + cnpanl(i)*qcnp -! -! snow over sea ice is cycled -! - if(slianl(i).eq.2.) then - snoanl(i) = snofcs(i) - endif -! - enddo - -! at landice points, set the soil type, slope type and -! greenness fields to flag values. - - if (landice) then - do i=i1_t,i2_t - if (nint(slianl(i)) == 1) then - if (nint(vetanl(i)) == veg_type_landice) then - sotanl(i) = soil_type_landice - veganl(i) = 0.0 - slpanl(i) = 9.0 - vmnanl(i) = 0.0 - vmxanl(i) = 0.0 - endif - end if ! if land - enddo - endif - - do i=i1_t,i2_t - cvanl(i) = cvfcs(i)*rcv + cvanl(i)*qcv - cvbanl(i) = cvbfcs(i)*rcvb + cvbanl(i)*qcvb - cvtanl(i) = cvtfcs(i)*rcvt + cvtanl(i)*qcvt - enddo -! - do k = 1, 4 - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - albanl(i,k) = albfcs(i,k)*ralbs + albanl(i,k)*qalbs - else - albanl(i,k) = albfcs(i,k)*ralbl + albanl(i,k)*qalbl - endif - enddo - enddo -! - do k = 1, 2 - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - alfanl(i,k) = alffcs(i,k)*ralfs + alfanl(i,k)*qalfs - else - alfanl(i,k) = alffcs(i,k)*ralfl + alfanl(i,k)*qalfl - endif - enddo - enddo -! - do k = 1, lsoil - do i=i1_t,i2_t - if(slianl(i).eq.0.) then - smcanl(i,k) = smcfcs(i,k)*rsmcs(k) + smcanl(i,k)*qsmcs(k) - stcanl(i,k) = stcfcs(i,k)*rstcs(k) + stcanl(i,k)*qstcs(k) - else -! soil moisture not used at landice points, so -! don't bother merging it. also, for now don't allow nudging -! to raise subsurface temperature above freezing. - stcanl(i,k) = stcfcs(i,k)*rstcl(k) + stcanl(i,k)*qstcl(k) - if (landice .and. slianl(i) == 1.0 .and. - & nint(vetanl(i)) == veg_type_landice) then - smcanl(i,k) = 1.0 ! use value as flag - stcanl(i,k) = min(stcanl(i,k), 273.15) - else - smcanl(i,k) = smcfcs(i,k)*rsmcl(k) + smcanl(i,k)*qsmcl(k) - end if - endif - enddo - enddo -! - enddo ! end of threaded loop ................... -!$omp end parallel do - return - end subroutine merge - -!>\ingroup mod_sfcsub - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & sihnew,sicnew,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albsea,snosea,zorsea,smcsea,smcice, - & tsfmin,tsfice,albice,zorice,tgice, - & rla,rlo,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, - & smcice,tsfmin,zorsea,smcsea -!cwu [+1l] add sicnew,sihnew - &, sicnew,sihnew - integer i,me,kount1,kount2,k,len,lsoil - real (kind=kind_io8) slianl(len), slifcs(len), - & tsffcs(len),tsfanl(len) - real (kind=kind_io8) albanl(len,4), snoanl(len), zoranl(len) - real (kind=kind_io8) smcanl(len,lsoil), stcanl(len,lsoil) -!cwu [+1l] add sihanl & sicanl - real (kind=kind_io8) sihanl(len), sicanl(len) -! - real (kind=kind_io8) rla(len), rlo(len) -! - if (me .eq. 0) write(6,*) 'newice' -! - kount1 = 0 - kount2 = 0 - do i=1,len - if(slifcs(i).ne.slianl(i)) then - if(slifcs(i).eq.1..or.slianl(i).eq.1.) then - print *,'inconsistency in slifcs or slianl' - print 910,rla(i),rlo(i),slifcs(i),slianl(i), - & tsffcs(i),tsfanl(i) - 910 format(2x,'at lat=',f5.1,' lon=',f5.1,' slifcs=',f4.1, - & ' slimsk=',f4.1,' tsffcs=',f5.1,' set to tsfanl=',f5.1) - call abort - endif -! -! interpolated climatology indicates melted sea ice -! - if(slianl(i).eq.0..and.slifcs(i).eq.2.) then - tsfanl(i) = tsfmin - albanl(i,1) = albsea - albanl(i,2) = albsea - albanl(i,3) = albsea - albanl(i,4) = albsea - snoanl(i) = snosea - zoranl(i) = zorsea - do k = 1, lsoil - smcanl(i,k) = smcsea -!cwu [+1l] set stcanl to tgice (over sea-ice) - stcanl(i,k) = tgice - enddo -!cwu [+2l] set siganl and sicanl - sihanl(i) = 0. - sicanl(i) = 0. - kount1 = kount1 + 1 - endif -! -! interplated climatoloyg/analysis indicates new sea ice -! - if(slianl(i).eq.2..and.slifcs(i).eq.0.) then - tsfanl(i) = tsfice - albanl(i,1) = albice - albanl(i,2) = albice - albanl(i,3) = albice - albanl(i,4) = albice - snoanl(i) = 0. - zoranl(i) = zorice - do k = 1, lsoil - smcanl(i,k) = smcice - stcanl(i,k) = tgice - enddo -!cwu [+2l] add sihanl & sicanl - sihanl(i) = sihnew - sicanl(i) = min(one, max(sicnew,sicanl(i))) - kount2 = kount2 + 1 - endif - endif - enddo -! - if (me .eq. 0) then - if(kount1.gt.0) then - write(6,*) 'sea ice melted. tsf,alb,zor are filled', - & ' at ',kount1,' points' - endif - if(kount2.gt.0) then - write(6,*) 'sea ice formed. tsf,alb,zor are filled', - & ' at ',kount2,' points' - endif - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, - & landice,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,i,len,me - logical, intent(in) :: landice - real (kind=kind_io8) per,snoval - real (kind=kind_io8) snoanl(len),slmask(len), - & aisanl(len),glacir(len) - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) 'qc of snow' - endif - if (.not.landice) then - kount=0 - do i=1,len - if(glacir(i).ne.0..and.snoanl(i).eq.0.) then -! if(glacir(i).ne.0..and.snoanl(i).lt.snoval*0.5) then - snoanl(i) = snoval - kount = kount + 1 - endif - enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if (me .eq. 0) then - print *,'snow filled over glacier points at ',kount, - & ' points (',per,'percent)' - endif - endif - endif ! landice check - kount = 0 - do i=1,len - if(slmask(i).eq.0.and.aisanl(i).eq.0) then - snoanl(i) = 0. - kount = kount + 1 - endif - enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if (me .eq. 0) then - print *,'snow set to zero over open sea at ',kount, - & ' points (',per,'percent)' - endif - endif - return - end subroutine qcsnow - -!>\ingroup mod_sfcsub - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, - & rla,rlo,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount1,kount,i,me,len - real (kind=kind_io8) per,aicsea,aicice,sllnd -! - real (kind=kind_io8) ais(len), glacir(len), - & amxice(len), slmask(len) - real (kind=kind_io8) rla(len), rlo(len) -! -! check sea-ice cover mask against land-sea mask -! - if (me .eq. 0) write(6,*) 'qc of sea ice' - kount = 0 - kount1 = 0 - do i=1,len - if(ais(i).ne.aicice.and.ais(i).ne.aicsea) then - print *,'sea ice mask not ',aicice,' or ',aicsea - print *,'ais(i),aicice,aicsea,rla(i),rlo(i,=', - & ais(i),aicice,aicsea,rla(i),rlo(i) - call abort - endif - if(slmask(i).eq.0..and.glacir(i).eq.1..and. -! if(slmask(i).eq.0..and.glacir(i).eq.2..and. - & ais(i).ne.1.) then - kount1 = kount1 + 1 - ais(i) = 1. - endif - if(slmask(i).eq.sllnd.and.ais(i).eq.aicice) then - kount = kount + 1 - ais(i) = aicsea - endif - enddo -! enddo - per = float(kount) / float(len)*100. - if(kount.gt.0) then - if(me .eq. 0) then - print *,' sea ice over land mask at ',kount,' points (',per, - & 'percent)' - endif - endif - per = float(kount1) / float(len)*100. - if(kount1.gt.0) then - if(me .eq. 0) then - print *,' sea ice set over glacier points over ocean at ', - & kount1,' points (',per,'percent)' - endif - endif -! kount=0 -! do j=1,jdim -! do i=1,idim -! if(amxice(i,j).ne.0..and.ais(i,j).eq.0.) then -! ais(i,j)=0. -! kount=kount+1 -! endif -! enddo -! enddo -! per=float(kount)/float(idim*jdim)*100. -! if(kount.gt.0) then -! print *,' sea ice exceeds maxice at ',kount,' points (',per, -! & 'percent)' -! endif -! -! remove isolated open ocean surrounded by sea ice and/or land -! -! remove isolated open ocean surrounded by sea ice and/or land -! -! ij = 0 -! do j=1,jdim -! do i=1,idim -! ij = ij + 1 -! ip = i + 1 -! im = i - 1 -! jp = j + 1 -! jm = j - 1 -! if(jp.gt.jdim) jp = jdim - 1 -! if(jm.lt.1) jm = 2 -! if(ip.gt.idim) ip = 1 -! if(im.lt.1) im = idim -! if(slmask(i,j).eq.0..and.ais(i,j).eq.0.) then -! if((slmask(ip,jp).eq.1..or.ais(ip,jp).eq.1.).and. -! & (slmask(i ,jp).eq.1..or.ais(i ,jp).eq.1.).and. -! & (slmask(im,jp).eq.1..or.ais(im,jp).eq.1.).and. -! & (slmask(ip,j ).eq.1..or.ais(ip,j ).eq.1.).and. -! & (slmask(im,j ).eq.1..or.ais(im,j ).eq.1.).and. -! & (slmask(ip,jm).eq.1..or.ais(ip,jm).eq.1.).and. -! & (slmask(i ,jm).eq.1..or.ais(i ,jm).eq.1.).and. -! & (slmask(im,jm).eq.1..or.ais(im,jm).eq.1.)) then -! ais(i,j) = 1. -! write(6,*) ' isolated open sea point surrounded by', -! & ' sea ice or land modified to sea ice', -! & ' at lat=',rla(i,j),' lon=',rlo(i,j) -! endif -! endif -! enddo -! enddo - return - end - -!>\ingroup mod_sfcsub - subroutine setlsi(slmask,aisfld,len,aicice,slifld) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) aicice - real (kind=kind_io8) slmask(len), slifld(len), aisfld(len) -! -! set surface condition indicator slimsk -! - do i=1,len - slifld(i) = slmask(i) -! if(aisfld(i).eq.aicice) slifld(i) = 2.0 - if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) - & slifld(i) = 2.0 - enddo - return - end -!>\ingroup mod_sfcsub - subroutine scale(fld,len,scl) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) fld(len),scl - do i=1,len - fld(i) = fld(i) * scl - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, - & rla,rlo,len,mode,percrit,lgchek,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, - & fldlmx,fldlmn,fldomx,fldjmn,percrit, - & fldsmx,fldsmn,epsfld - integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, - & ij,nprt,kmaxs,kmins,i,me,len,mode - parameter(mmprt=2) -! - character*8 ttl - logical iceflg(len) - real (kind=kind_io8) fld(len),slimsk(len),sno(len), - & rla(len), rlo(len) - integer iwk(len) - logical lgchek -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! -! check against land-sea mask and ice cover mask -! - if(me .eq. 0) then -! print *,' ' - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' - endif -! - len_thread_m = (len+num_threads-1) / num_threads - kmaxl = 0 - kminl = 0 - kmaxo = 0 - kmino = 0 - kmaxi = 0 - kmini = 0 - kmaxj = 0 - kminj = 0 - kmaxs = 0 - kmins = 0 -!$omp parallel do private(i1_t,i2_t,it,i) -!$omp+private(nprt,ij,iwk) -!$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) -!$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) -!$omp+shared(mode,epsfld) -!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) -!$omp+shared(fld,slimsk,sno,rla,rlo) - do it=1,num_threads ! start of threaded loop - i1_t = (it-1)*len_thread_m+1 - i2_t = min(i1_t+len_thread_m-1,len) -! -! -! -! lower bound check over bare land -! - if (fldlmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).lt.fldlmn-epsfld) then - kminl=kminl+1 - iwk(kminl) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kminl) - do i=1,nprt - ij = iwk(i) - print 8001,rla(ij),rlo(ij),fld(ij),fldlmn - 8001 format(' bare land min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) - enddo - endif - if (mode .eq. 1) then - do i=1,kminl - fld(iwk(i)) = fldlmn - enddo - endif - endif -! -! upper bound check over bare land -! - if (fldlmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).gt.fldlmx+epsfld) then - kmaxl=kmaxl+1 - iwk(kmaxl) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxl) - do i=1,nprt - ij = iwk(i) - print 8002,rla(ij),rlo(ij),fld(ij),fldlmx - 8002 format(' bare land max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxl - fld(iwk(i)) = fldlmx - enddo - endif - endif -! -! lower bound check over snow covered land -! - if (fldsmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).lt.fldsmn-epsfld) then - kmins=kmins+1 - iwk(kmins) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmins) - do i=1,nprt - ij = iwk(i) - print 8003,rla(ij),rlo(ij),fld(ij),fldsmn - 8003 format(' sno covrd land min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmins - fld(iwk(i)) = fldsmn - enddo - endif - endif -! -! upper bound check over snow covered land -! - if (fldsmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).gt.fldsmx+epsfld) then - kmaxs=kmaxs+1 - iwk(kmaxs) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxs) - do i=1,nprt - ij = iwk(i) - print 8004,rla(ij),rlo(ij),fld(ij),fldsmx - 8004 format(' snow land max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxs - fld(iwk(i)) = fldsmx - enddo - endif - endif -! -! lower bound check over open ocean -! - if (fldomn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.0..and. - & fld(i).lt.fldomn-epsfld) then - kmino=kmino+1 - iwk(kmino) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmino) - do i=1,nprt - ij = iwk(i) - print 8005,rla(ij),rlo(ij),fld(ij),fldomn - 8005 format(' open ocean min. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmino - fld(iwk(i)) = fldomn - enddo - endif - endif -! -! upper bound check over open ocean -! - if (fldomx .ne. 999.0) then - do i=i1_t,i2_t - if(fldomx.ne.999..and.slimsk(i).eq.0..and. - & fld(i).gt.fldomx+epsfld) then - kmaxo=kmaxo+1 - iwk(kmaxo) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxo) - do i=1,nprt - ij = iwk(i) - print 8006,rla(ij),rlo(ij),fld(ij),fldomx - 8006 format(' open ocean max. check. lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxo - fld(iwk(i)) = fldomx - enddo - endif - endif -! -! lower bound check over sea ice without snow -! - if (fldimn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).lt.fldimn-epsfld) then - kmini=kmini+1 - iwk(kmini) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmini) - do i=1,nprt - ij = iwk(i) - print 8007,rla(ij),rlo(ij),fld(ij),fldimn - 8007 format(' seaice no snow min. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmini - fld(iwk(i)) = fldimn - enddo - endif - endif -! -! upper bound check over sea ice without snow -! - if (fldimx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then -! & fld(i).gt.fldimx+epsfld) then - kmaxi=kmaxi+1 - iwk(kmaxi) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxi) - do i=1,nprt - ij = iwk(i) - print 8008,rla(ij),rlo(ij),fld(ij),fldimx - 8008 format(' seaice no snow max. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxi - fld(iwk(i)) = fldimx - enddo - endif - endif -! -! lower bound check over sea ice with snow -! - if (fldjmn .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).lt.fldjmn-epsfld) then - kminj=kminj+1 - iwk(kminj) = i - endif - enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kminj) - do i=1,nprt - ij = iwk(i) - print 8009,rla(ij),rlo(ij),fld(ij),fldjmn - 8009 format(' sea ice snow min. check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kminj - fld(iwk(i)) = fldjmn - enddo - endif - endif -! -! upper bound check over sea ice with snow -! - if (fldjmx .ne. 999.0) then - do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then -! & fld(i).gt.fldjmx+epsfld) then - kmaxj=kmaxj+1 - iwk(kmaxj) = i - endif - enddo - if(me == 0 .and. it == 1 .and. num_threads == 1) then - nprt = min(mmprt,kmaxj) - do i=1,nprt - ij = iwk(i) - print 8010,rla(ij),rlo(ij),fld(ij),fldjmx - 8010 format(' seaice snow max check lat=',f5.1, - & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) - enddo - endif - if (mode .eq. 1) then - do i=1,kmaxj - fld(iwk(i)) = fldjmx - enddo - endif - endif - enddo ! end of threaded loop -!$omp end parallel do -! -! print results -! - if(me .eq. 0) then -! write(6,*) 'summary of qc' - permax=0. - if(kminl.gt.0) then - per=float(kminl)/float(len)*100. - print 9001,fldlmn,kminl,per - 9001 format(' bare land min check. modified to ',f8.1, - & ' at ',i5,' points ',f8.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxl.gt.0) then - per=float(kmaxl)/float(len)*100. - print 9002,fldlmx,kmaxl,per - 9002 format(' bare land max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmino.gt.0) then - per=float(kmino)/float(len)*100. - print 9003,fldomn,kmino,per - 9003 format(' open ocean min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxo.gt.0) then - per=float(kmaxo)/float(len)*100. - print 9004,fldomx,kmaxo,per - 9004 format(' open sea max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmins.gt.0) then - per=float(kmins)/float(len)*100. - print 9009,fldsmn,kmins,per - 9009 format(' snow covered land min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxs.gt.0) then - per=float(kmaxs)/float(len)*100. - print 9010,fldsmx,kmaxs,per - 9010 format(' snow covered land max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmini.gt.0) then - per=float(kmini)/float(len)*100. - print 9005,fldimn,kmini,per - 9005 format(' bare ice min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxi.gt.0) then - per=float(kmaxi)/float(len)*100. - print 9006,fldimx,kmaxi,per - 9006 format(' bare ice max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kminj.gt.0) then - per=float(kminj)/float(len)*100. - print 9007,fldjmn,kminj,per - 9007 format(' snow covered ice min check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif - if(kmaxj.gt.0) then - per=float(kmaxj)/float(len)*100. - print 9008,fldjmx,kmaxj,per - 9008 format(' snow covered ice max check. modified to ',f8.1, - & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per - endif -! commented on 06/30/99 -- moorthi -! if(lgchek) then -! if(permax.gt.percrit) then -! write(6,*) ' too many bad points. aborting ....' -! call abort -! endif -! endif -! - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine setzro(fld,eps,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) fld(len),eps - do i=1,len - if(abs(fld(i)).lt.eps) fld(i) = 0. - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine getscv(snofld,scvfld,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) snofld(len),scvfld(len) -! - do i=1,len - scvfld(i) = 0. - if(snofld(i).gt.0.) scvfld(i) = 1. - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine getstc(tsffld,tg3fld,slifld,len,lsoil,stcfld,tsfimx) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer k,i,len,lsoil - real (kind=kind_io8) factor,tsfimx - real (kind=kind_io8) tsffld(len), tg3fld(len), slifld(len) - real (kind=kind_io8) stcfld(len,lsoil) -! -! layer soil temperature -! - do k = 1, lsoil - do i = 1, len - if(slifld(i).eq.1.0) then - factor = ((k-1) * 2 + 1) / (2. * lsoil) - stcfld(i,k) = factor*tg3fld(i)+(1.-factor)*tsffld(i) - elseif(slifld(i).eq.2.0) then - factor = ((k-1) * 2 + 1) / (2. * lsoil) - stcfld(i,k) = factor*tsfimx+(1.-factor)*tsffld(i) - else - stcfld(i,k) = tg3fld(i) - endif - enddo - enddo - if(lsoil.gt.2) then - do k = 3, lsoil - do i = 1, len - stcfld(i,k) = stcfld(i,2) - enddo - enddo - endif - return - end - -!>\ingroup mod_sfcsub -!! This subroutine calculates layer soil wetness. - subroutine getsmc(wetfld,len,lsoil,smcfld,me) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer k,i,len,lsoil,me - real (kind=kind_io8) wetfld(len), smcfld(len,lsoil) -! - if (me .eq. 0) write(6,*) 'getsmc' -! -! layer soil wetness -! - do k = 1, lsoil - do i = 1, len - smcfld(i,k) = (wetfld(i)*1000./150.)*.37 + .1 - enddo - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, - & tsfimx) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len,lsoil - real (kind=kind_io8) tsfimx - real (kind=kind_io8) sig1t(len), slianl(len), tg3anl(len) - real (kind=kind_io8) tsfanl(len), stcanl(len,lsoil) -! -! soil temperature -! - if(sig1t(1).gt.0.) then - do i=1,len - if(slianl(i).ne.0.) then - tsfanl(i) = sig1t(i) - endif - enddo - endif - call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) -! - return - end - -!>\ingroup mod_sfcsub - subroutine snosfc(snoanl,tsfanl,tsfsmx,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,i,len,me - real (kind=kind_io8) per,tsfsmx - real (kind=kind_io8) snoanl(len), tsfanl(len) -! - if (me .eq. 0) write(6,*) 'set snow temp to tsfsmx if greater' - kount=0 - do i=1,len - if(snoanl(i).gt.0.) then - if(tsfanl(i).gt.tsfsmx) tsfanl(i)=tsfsmx - kount = kount + 1 - endif - enddo - if(kount.gt.0) then - if(me .eq. 0) then - per=float(kount)/float(len)*100. - write(6,*) 'snow sfc. tsf set to ',tsfsmx,' at ', - & kount, ' points ',per,'percent' - endif - endif - return - end - -!>\ingroup mod_sfcsub - subroutine albocn(albclm,slmask,albomx,len) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) albomx - real (kind=kind_io8) albclm(len,4), slmask(len) - do i=1,len - if(slmask(i).eq.0) then - albclm(i,1) = albomx - albclm(i,2) = albomx - albclm(i,3) = albomx - albclm(i,4) = albomx - endif - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine qcmxice(glacir,amxice,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,kount,len,me - real (kind=kind_io8) glacir(len),amxice(len),per - if (me .eq. 0) write(6,*) 'qc of maximum ice extent' - kount=0 - do i=1,len - if(glacir(i).eq.1..and.amxice(i).eq.0.) then - amxice(i) = 0. - kount = kount + 1 - endif - enddo - if(kount.gt.0) then - per = float(kount) / float(len)*100. - if(me .eq. 0) write(6,*) ' max ice limit less than glacier' - &, ' coverage at ', kount, ' points ',per,'percent' - endif - return - end - -!>\ingroup mod_sfcsub - subroutine qcsli(slianl,slifcs,len,me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,kount,len,me - real (kind=kind_io8) slianl(len), slifcs(len),per - if (me .eq. 0) then - write(6,*) ' ' - write(6,*) 'qcsli' - endif - kount=0 - do i=1,len - if(slianl(i).eq.1..and.slifcs(i).eq.0.) then - kount = kount + 1 - slifcs(i) = 1. - endif - if(slianl(i).eq.0..and.slifcs(i).eq.1.) then - kount = kount + 1 - slifcs(i) = 0. - endif - if(slianl(i).eq.2..and.slifcs(i).eq.1.) then - kount = kount + 1 - slifcs(i) = 0. - endif - if(slianl(i).eq.1..and.slifcs(i).eq.2.) then - kount = kount + 1 - slifcs(i) = 1. - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if(me .eq. 0) then - write(6,*) ' inconsistency of slmask between forecast and', - & ' analysis corrected at ',kount, ' points ',per, - & 'percent' - endif - endif - return - end -! subroutine nntprt(data,imax,fact) -! real (kind=kind_io8) data(imax) -! ilast=0 -! i1=1 -! i2=80 -!1112 continue -! if(i2.ge.imax) then -! ilast=1 -! i2=imax -! endif -! write(6,*) ' ' -! do j=1,jmax -! write(6,1111) (nint(data(imax*(j-1)+i)*fact),i=i1,i2) -! enddo -! if(ilast.eq.1) return -! i1=i1+80 -! i2=i1+79 -! if(i2.ge.imax) then -! ilast=1 -! i2=imax -! endif -! go to 1112 -!1111 format(80i1) -! return -! end - -!>\ingroup mod_sfcsub - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx, me) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer kount,me,k,i,lsoil,len - real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx - real (kind=kind_io8) tsffcs(len), snofcs(len) - real (kind=kind_io8) snoanl(len), aisanl(len), - & slianl(len), zoranl(len), - & tsfanl(len), albanl(len,4), - & smcanl(len,lsoil) - real (kind=kind_io8) smcclm(len,lsoil) -! - if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' -! -! qc of snow analysis -! -! questionable snow cover -! - kount = 0 - do i=1,len - if(slianl(i).gt.0..and. - & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then - kount = kount + 1 - snoanl(i) = 0. - tsfanl(i) = tsffcs(i) - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if (me .eq. 0) then - write(6,*) ' guess surface temp .gt. ',qctsfs, - & ' but snow analysis indicates snow cover' - write(6,*) ' snow analysis set to zero', - & ' at ',kount, ' points ',per,'percent' - endif - endif -! -! questionable no snow cover -! - kount = 0 - do i=1,len - if(slianl(i).gt.0..and. - & snofcs(i).gt.qcsnos.and.snoanl(i).lt.0.) then - kount = kount + 1 - snoanl(i) = snofcs(i) - tsfanl(i) = tsffcs(i) - endif - enddo - if(kount.gt.0) then - per=float(kount)/float(len)*100. - if (me .eq. 0) then - write(6,*) ' guess snow depth .gt. ',qcsnos, - & ' but snow analysis indicates no snow cover' - write(6,*) ' snow analysis set to guess value', - & ' at ',kount, ' points ',per,'percent' - endif - endif -! -! questionable sea ice cover ! this qc is disable to correct error in -! surface temparature over observed sea ice points -! -! kount = 0 -! do i=1,len -! if(slianl(i).eq.2..and. -! & tsffcs(i).gt.qctsfi.and.aisanl(i).eq.1.) then -! kount = kount + 1 -! aisanl(i) = 0. -! slianl(i) = 0. -! tsfanl(i) = tsffcs(i) -! snoanl(i) = 0. -! zoranl(i) = zoromx -! albanl(i,1) = albomx -! albanl(i,2) = albomx -! albanl(i,3) = albomx -! albanl(i,4) = albomx -! do k=1,lsoil -! smcanl(i,k) = smcclm(i,k) -! enddo -! endif -! enddo -! if(kount.gt.0) then -! per=float(kount)/float(len)*100. -! if (me .eq. 0) then -! write(6,*) ' guess surface temp .gt. ',qctsfi, -! & ' but sea-ice analysis indicates sea-ice' -! write(6,*) ' sea-ice analysis set to zero', -! & ' at ',kount, ' points ',per,'percent' -! endif -! endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, - & data,imax,jmax,rlnout,rltout,lmask,rslmsk - &, gaus,blno, blto, kgds1, kpds4, lbms) - use machine , only : kind_io8,kind_io4 - use sfccyc_module - implicit none - real (kind=kind_io8) blno,blto,wlon,rnlat,crit,data_max - integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla - integer, intent(in) :: kpds4 - logical*1, intent(in) :: lbms(imax,jmax) - real*4 :: dummy(imax,jmax) - - real (kind=kind_io8) slmask(igaul,jgaul) - real (kind=kind_io8) data(imax,jmax),rslmsk(imax,jmax) - &, rlnout(imax), rltout(jmax) - real (kind=kind_io8) a(jmax), w(jmax), radi, dlat, dlon - logical lmask, gaus -! -! set the longitude and latitudes for the grib file -! - if (kgds1 .eq. 4) then ! grib file on gaussian grid - kspla=4 - call splat(kspla, jmax, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do j=1,jmax - rltout(j) = acos(a(j)) * radi - enddo -! - if (rnlat .gt. 0.0) then - do j=1,jmax - rltout(j) = 90. - rltout(j) - enddo - else - do j=1,jmax - rltout(j) = -90. + rltout(j) - enddo - endif - elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid - dlat = -(rnlat+rnlat) / float(jmax-1) - do j=1,jmax - rltout(j) = rnlat + (j-1) * dlat - enddo - else ! grib file on some other grid - call abort - endif - dlon = 360.0 / imax - do i=1,imax - rlnout(i) = wlon + (i-1)*dlon - enddo -! -! - ijmax = imax*jmax - rslmsk = 0. -! -! surface temperature -! - if(kpds5.eq.kpdtsf) then -! lmask=.false. - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! -! bucket soil wetness -! - elseif(kpds5.eq.kpdwet) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'wet rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! snow depth -! - elseif(kpds5.eq.kpdsnd) then - if(kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask=.true. - else - lmask=.false. - end if -! -! snow liq equivalent depth -! - elseif(kpds5.eq.kpdsno) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'sno rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! soil moisture -! - elseif(kpds5.eq.kpdsmc) then - if(kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask=.true. - else - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. - endif -! -! surface roughness -! - elseif(kpds5.eq.kpdzor) then - do j=1,jmax - do i=1,imax - rslmsk(i,j)=data(i,j) - enddo - enddo - crit=9.9 - call rof01(rslmsk,ijmax,'lt',crit) - lmask=.true. -! write(6,*) 'zor rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! albedo -! -! elseif(kpds5.eq.kpdalb) then -! do j=1,jmax -! do i=1,imax -! rslmsk(i,j)=data(i,j) -! enddo -! enddo -! crit=99. -! call rof01(rslmsk,ijmax,'lt',crit) -! lmask=.true. -! write(6,*) 'alb rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! albedo -! -!cbosu new snowfree albedo database has bitmap, use it. - elseif(kpds5.eq.kpdalb(1)) then - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(2)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(3)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if - elseif(kpds5.eq.kpdalb(4)) then -!cbosu - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has no water flag. - lmask=.false. - end if -! -! vegetation fraction for albedo -! - elseif(kpds5.eq.kpdalf(1)) then -! rslmsk=data -! crit=0. -! call rof01(rslmsk,ijmax,'gt',crit) -! lmask=.true. - lmask=.false. - elseif(kpds5.eq.kpdalf(2)) then -! rslmsk=data -! crit=0. -! call rof01(rslmsk,ijmax,'gt',crit) -! lmask=.true. - lmask=.false. -! -! sea ice -! - elseif(kpds5.eq.kpdais) then - lmask=.false. -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! - data_max = 0.0 - do j=1,jmax - do i=1,imax - rslmsk(i,j) = data(i,j) - data_max= max(data_max,data(i,j)) - enddo - enddo - crit=1.0 - if (data_max .gt. crit) then - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. - else - lmask=.false. - endif -! write(6,*) 'acn rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! deep soil temperature -! - elseif(kpds5.eq.kpdtg3) then - lmask=.false. -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! lmask=.true. -! -! plant resistance -! -! elseif(kpds5.eq.kpdplr) then -! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat -! &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) -! crit=0.5 -! call rof01(rslmsk,ijmax,'ge',crit) -! lmask=.true. -! -! write(6,*) 'plr rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! glacier points -! - elseif(kpds5.eq.kpdgla) then - lmask=.false. -! -! max ice extent -! - elseif(kpds5.eq.kpdmxi) then - lmask=.false. -! -! snow cover -! - elseif(kpds5.eq.kpdscv) then - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'scv rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! sea ice concentration -! - elseif(kpds5.eq.kpdacn) then - lmask=.false. - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) -! &, dlon, dlat, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. -! write(6,*) 'acn rslmsk' -! znnt=1. -! call nntprt(rslmsk,ijmax,znnt) -! -! vegetation cover -! - elseif(kpds5.eq.kpdveg) then -!cggg - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction - end if - enddo - enddo - lmask = .true. - else ! no bitmap, set mask the old way. - - call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat - &, rlnout, rltout, gaus, blno, blto) - crit=0.5 - call rof01(rslmsk,ijmax,'ge',crit) - lmask=.true. - - end if -! -! soil type -! - elseif(kpds5.eq.kpdsot) then - - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo -! soil type is zero over water, use this to get a bitmap. - else - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - endif - lmask=.true. -! -! vegetation type -! - elseif(kpds5.eq.kpdvet) then - - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo -! veg type is zero over water, use this to get a bitmap. - else - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - endif - lmask=.true. -! -! these are for four new data type added by clu -- not sure its correct! -! - elseif(kpds5.eq.kpdvmn) then -! -!cggg greenness is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! - elseif(kpds5.eq.kpdvmx) then -! -!cggg greenness is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! - elseif(kpds5.eq.kpdslp) then -! -!cggg slope type is zero over water, use this to get a bitmap. -! - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo -! - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. -!cggg lmask=.false. -! -!cbosu new maximum snow albedo database has bitmap - elseif(kpds5.eq.kpdabs) then - if (kpds4 == 192) then ! use the bitmap - rslmsk = 0. - do j = 1, jmax - do i = 1, imax - if (lbms(i,j)) then - rslmsk(i,j) = 1. - end if - enddo - enddo - lmask = .true. - else ! no bitmap. old database has zero over water - do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo - enddo - crit=0.1 - call rof01(rslmsk,ijmax,'gt',crit) - lmask=.true. - end if - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, - & wlon,rnlat,rlnout,rltout,gaus,blno, blto) - use machine , only : kind_io8,kind_io4 - implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, - & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, - & rnlat,dxout,dphi,dlat,facns,tem,blno, - & blto -! -! interpolation from lat/lon grid to other lat/lon grid -! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) - &, rlnout(imxout), rltout(jmxout) - logical gaus -! - real, allocatable :: gaul(:) - real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), - & jindx1(jmxout), jindx2(jmxout) - integer jmxsav,n,kspla - data jmxsav/0/ - save jmxsav, gaul, dlati - real (kind=kind_io8) radi - real (kind=kind_io8) a(jmxin), w(jmxin) -! -! - logical first - integer num_threads - data first /.true./ - save num_threads, first -! - integer len_thread_m, j1_t, j2_t, it - integer num_parthds -! - if (first) then - num_threads = num_parthds() - first = .false. - endif -! - if (jmxin .ne. jmxsav) then - if (jmxsav .gt. 0) deallocate (gaul, stat=iret) - allocate (gaul(jmxin)) - jmxsav = jmxin - if (gaus) then -cjfe call gaulat(gaul,jmxin) -cjfe -! - kspla=4 - call splat(kspla, jmxin, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do n=1,jmxin - gaul(n) = acos(a(n)) * radi - enddo -cjfe - do j=1,jmxin - gaul(j) = 90. - gaul(j) - enddo - else - dlat = -2*blto / float(jmxin-1) - dlati = 1 / dlat - do j=1,jmxin - gaul(j) = blto + (j-1) * dlat - enddo - endif - endif -! -! - dxin = 360. / float(imxin ) -! - do i=1,imxout - alamd = rlnout(i) - i1 = floor((alamd-blno)/dxin) + 1 - ddx(i) = (alamd-blno)/dxin-(i1-1) - iindx1(i) = modulo(i1-1,imxin) + 1 - iindx2(i) = modulo(i1 ,imxin) + 1 - enddo -! -! - len_thread_m = (jmxout+num_threads-1) / num_threads -! - if (gaus) then -! -!$omp parallel do private(j1_t,j2_t,it,j1,j2,jj) -!$omp+private(aphi) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - j2=1 - do 40 j=j1_t,j2_t - aphi=rltout(j) - do 50 jj=1,jmxin - if(aphi.lt.gaul(jj)) go to 50 - j2=jj - go to 42 - 50 continue - 42 continue - if(j2.gt.2) go to 43 - j1=1 - j2=2 - go to 44 - 43 continue - if(j2.le.jmxin) go to 45 - j1=jmxin-1 - j2=jmxin - go to 44 - 45 continue - j1=j2-1 - 44 continue - jindx1(j)=j1 - jindx2(j)=j2 - ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) - 40 continue - enddo ! end of threaded loop ................... -!$omp end parallel do -! - else -!$omp parallel do private(j1_t,j2_t,it,j1,j2,jtem) -!$omp+private(aphi) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy,dlati,blto) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - j2=1 - do 400 j=j1_t,j2_t - aphi=rltout(j) - jtem = (aphi - blto) * dlati + 1 - if (jtem .ge. 1 .and. jtem .lt. jmxin) then - j1 = jtem - j2 = j1 + 1 - ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) - elseif (jtem .eq. jmxin) then - j1 = jmxin - j2 = jmxin - ddy(j)=1.0 - else - j1 = 1 - j2 = 1 - ddy(j)=1.0 - endif -! - jindx1(j) = j1 - jindx2(j) = j2 - 400 continue - enddo ! end of threaded loop ................... -!$omp end parallel do - endif -! -! write(6,*) 'ga2la' -! write(6,*) 'iindx1' -! write(6,*) (iindx1(n),n=1,imxout) -! write(6,*) 'iindx2' -! write(6,*) (iindx2(n),n=1,imxout) -! write(6,*) 'jindx1' -! write(6,*) (jindx1(n),n=1,jmxout) -! write(6,*) 'jindx2' -! write(6,*) (jindx2(n),n=1,jmxout) -! write(6,*) 'ddy' -! write(6,*) (ddy(n),n=1,jmxout) -! write(6,*) 'ddx' -! write(6,*) (ddx(n),n=1,jmxout) -! -! -!$omp parallel do private(j1_t,j2_t,it,i,i1,i2) -!$omp+private(j,j1,j2,x,y) -!$omp+shared(num_threads,len_thread_m) -!$omp+shared(imxout,iindx1,jindx1,ddx,ddy,gauin,regout) -! - do it=1,num_threads ! start of threaded loop ................... - j1_t = (it-1)*len_thread_m+1 - j2_t = min(j1_t+len_thread_m-1,jmxout) -! - do j=j1_t,j2_t - y = ddy(j) - j1 = jindx1(j) - j2 = jindx2(j) - do i=1,imxout - x = ddx(i) - i1 = iindx1(i) - i2 = iindx2(i) - regout(i,j) = (1.-x)*((1.-y)*gauin(i1,j1) + y*gauin(i1,j2)) - & + x *((1.-y)*gauin(i2,j1) + y*gauin(i2,j2)) - enddo - enddo - enddo ! end of threaded loop ................... -!$omp end parallel do -! - sum1 = 0. - sum2 = 0. - do i=1,imxin - sum1 = sum1 + gauin(i,1) - sum2 = sum2 + gauin(i,jmxin) - enddo - sum1 = sum1 / float(imxin) - sum2 = sum2 / float(imxin) -! - if (gaus) then - if (rnlat .gt. 0.0) then - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - else - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - endif - else - if (blto .lt. 0.0) then - if (rnlat .gt. 0.0) then - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - else - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - endif - else - if (rnlat .lt. 0.0) then - do i=1,imxout - regout(i, 1) = sum2 - regout(i,jmxout) = sum1 - enddo - else - do i=1,imxout - regout(i, 1) = sum1 - regout(i,jmxout) = sum2 - enddo - endif - endif - endif -! - return - end - -!>\ingroup mod_sfcsub - subroutine landtyp(vegtype,soiltype,slptype,slmask,len) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) - +, slptype(len) -! -! make sure that the soil type and veg type are non-zero over land -! - do i = 1, len - if (slmask(i) .eq. 1) then - if (vegtype(i) .eq. 0.) vegtype(i) = 7 - if (soiltype(i) .eq. 0.) soiltype(i) = 2 - if (slptype(i) .eq. 0.) slptype(i) = 1 - endif - enddo - return - -!>\ingroup mod_sfcsub - end subroutine landtyp - subroutine gaulat(gaul,k) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer n,k - real (kind=kind_io8) radi - real (kind=kind_io8) a(k), w(k), gaul(k) -! - call splat(4, k, a, w) -! - radi = 180.0 / (4.*atan(1.)) - do n=1,k - gaul(n) = acos(a(n)) * radi - enddo -! -! print *,'gaussian lat (deg) for jmax=',k -! print *,(gaul(n),n=1,k) -! - return - 70 write(6,6000) - 6000 format(//5x,'error in gauaw'//) - stop - end -!----------------------------------------------------------------------- -!>\ingroup mod_sfcsub -!! The subroutine conducts time interpolation of anomalies, -!! and add initial anomaly to date interpolated climatology. - subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) -! - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), - & tsfclm(len), tsfcl0(len) -! -! time interpolation of anomalies -! add initial anomaly to date interpolated climatology -! - write(6,*) 'anomint' - do i=1,len - tsfanl(i) = tsfan0(i) - tsfcl0(i) + tsfclm(i) - enddo - return - end - -!>\ingroup mod_sfcsub - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb - &, tile_num_ch, i_index, j_index) -! - use machine , only : kind_io8,kind_io4 - implicit none - character(len=*), intent(in) :: tile_num_ch - integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, - & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 - real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb - &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat - integer kpdalb(4), kpdalf(2) -! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc,fnalbc2 - &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), - & wetclm(len),snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len),acnclm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) - &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) - real (kind=kind_io8) slmskh(imsk,jmsk) - real (kind=kind_io8) outlat(len), outlon(len) -! - real (kind=kind_io8) slmask(len), tsfcl0(len) - real (kind=kind_io8), allocatable :: slmask_noice(:) -! - logical lanom, gaus, first -! -! set z0 based on sib vegetation type - real (kind=kind_io8) z0_sib(13) - data z0_sib /2.653, 0.826, 0.563, 1.089, 0.854, 0.856, - & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125, - & 0.011 / -! set z0 based on igbp vegetation type - real (kind=kind_io8) z0_igbp_min(20), z0_igbp_max(20) - real (kind=kind_io8) z0_season(12) - data z0_igbp_min /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, - & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, - & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, - & 0.050, 0.030/ - data z0_igbp_max /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, - & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, - & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, - & 0.050, 0.030/ -! -! dayhf : julian day of the middle of each month -! - real (kind=kind_io8) dayhf(13) - data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, - & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ -! - real (kind=kind_io8) fha(5) - real(4) fha4(5) - integer w3kindreal,w3kindint - integer ida(8),jda(8),ivtyp, kpd7 -! - real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:), - & zor(:,:),wet(:,:), - & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:), - & tg3(:), alb(:,:,:), alf(:,:), - & vet(:), sot(:), tsf2(:), - & veg(:,:), stc(:,:,:) - &, vmn(:), vmx(:), slp(:), absm(:) -! - integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2 - data first/.true./ - data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/ -! - save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, - & alb, alf, vet, sot, tsf2, veg, stc, - & vmn, vmx, slp, absm, - & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, - & landice_cat -! - logical lprnt -! - do i=1,len - tsfclm(i) = 0.0 - tsfcl2(i) = 0.0 - snoclm(i) = 0.0 - wetclm(i) = 0.0 - zorclm(i) = 0.0 - aisclm(i) = 0.0 - tg3clm(i) = 0.0 - acnclm(i) = 0.0 - cvclm(i) = 0.0 - cvbclm(i) = 0.0 - cvtclm(i) = 0.0 - cnpclm(i) = 0.0 - sliclm(i) = 0.0 - scvclm(i) = 0.0 - vmnclm(i) = 0.0 - vmxclm(i) = 0.0 - slpclm(i) = 0.0 - absclm(i) = 0.0 - enddo - do k=1,lsoil - do i=1,len - smcclm(i,k) = 0.0 - stcclm(i,k) = 0.0 - enddo - enddo - do k=1,4 - do i=1,len - albclm(i,k) = 0.0 - enddo - enddo - do k=1,2 - do i=1,len - alfclm(i,k) = 0.0 - enddo - enddo -! - iret = 0 - monend = 9999 -! - if (first) then -! -! allocate variables to be saved -! - allocate (tsf(len,2), sno(len,2), zor(len,2), - & wet(len,2), ais(len,2), acn(len,2), - & scv(len,2), smc(len,lsoil,2), - & tg3(len), alb(len,4,2), alf(len,2), - & vet(len), sot(len), tsf2(len), -!clu [+1l] add vmn, vmx, slp, abs - & vmn(len), vmx(len), slp(len), absm(len), - & veg(len,2), stc(len,lsoil,2)) -! -! get tsf climatology for the begining of the forecast -! - if (fh .gt. 0.0) then -!cbosu - if (me == 0) print*,'bosu fh gt 0' - - iy4=iy - if(iy.lt.101) iy4=1900+iy4 - fha=0 - ida=0 - jda=0 -! fha(2)=nint(fh) - ida(1)=iy - ida(2)=im - ida(3)=id - ida(5)=ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal == 4) then - fha4=fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy=jda(1) - jm=jda(2) - jd=jda(3) - jh=jda(5) - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh', - & jy,jm,jd,jh - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday=jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. -! - if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! -! for monthly mean climatology -! - monend = 12 - do mm=1,monend - mmm=mm - mmp=mm+1 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - mon1=mmm - mon2=mmp - go to 10 - endif - enddo - print *,'wrong rjday',rjday - call abort - 10 continue - wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if(mon2.eq.13) mon2=1 - if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! read monthly mean climatology of tsf -! - kpd7 = -1 - do nn=1,2 - mon = mon1 - if (nn .eq. 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo -! -! tsf at the begining of forecast i.e. fh=0 -! - do i=1,len - tsfcl0(i) = wei1m * tsf(i,1) + wei2m * tsf(i,2) - enddo - endif - endif -! -! compute current jy,jm,jd,jh of forecast and the day of the year -! - iy4=iy - if(iy.lt.101) iy4=1900+iy4 - fha = 0 - ida = 0 - jda = 0 - fha(2) = nint(fh) - ida(1) = iy - ida(2) = im - ida(3) = id - ida(5) = ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - fha4=fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy = jda(1) - jm = jda(2) - jd = jda(3) - jh = jda(5) -! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', -! & jy,jm,jd,jh,rjday - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday = jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. - - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! -! for monthly mean climatology -! - monend = 12 - do mm=1,monend - mmm=mm - mmp=mm+1 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - mon1=mmm - mon2=mmp - go to 20 - endif - enddo - print *,'wrong rjday',rjday - call abort - 20 continue - wei1m=(dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) - wei2m=(rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if(mon2.eq.13) mon2=1 - if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! for seasonal mean climatology -! - monend = 4 - is = im/3 + 1 - if (is.eq.5) is = 1 - do mm=1,monend - mmm = mm*3 - 2 - mmp = (mm+1)*3 - 2 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - sea1 = mmm - sea2 = mmp - go to 30 - endif - enddo - print *,'wrong rjday',rjday - call abort - 30 continue - wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1)) - wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) - if(sea2.eq.13) sea2=1 - if (me .eq. 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', - & rjday,sea1,sea2,wei1s,wei2s -! -! for summer and winter values (maximum and minimum). -! - monend = 2 - is = im/6 + 1 - if (is.eq.3) is = 1 - do mm=1,monend - mmm = mm*6 - 5 - mmp = (mm+1)*6 - 5 - if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then - hyr1 = mmm - hyr2 = mmp - go to 31 - endif - enddo - print *,'wrong rjday',rjday - call abort - 31 continue - wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1)) - wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) - if(hyr2.eq.13) hyr2=1 - if (me .eq. 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', - & rjday,hyr1,hyr2,wei1y,wei2y -! -! start reading in climatology and interpolate to the date -! - first_time : if (first) then -!cbosu - if (me == 0) print*,'bosu first time thru' -! -! annual mean climatology -! -! fraction of vegetation field for albedo -- there are two -! fraction fields in this version: strong zenith angle dependent -! and weak zenith angle dependent -! - kpd9 = -1 -cjfe - alf=0. -cjfe - - kpd7=-1 - if (ialb == 1) then -!cbosu still need facsf and facwf. read them from the production -!cbosu file - if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask - &, alf,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnalbc2, tile_num_ch, i_index, j_index, - & kpdalf(1), alf(:,1), 1, len, me) - endif - else - call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask - &, alf,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif - do i = 1, len - if(slmask(i).eq.1.) then - alf(i,2) = 100. - alf(i,1) - endif - enddo -! -! deep soil temperature -! - if(fntg3c(1:8).ne.' ') then - if ( index(fntg3c, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, - & tg3,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fntg3c, tile_num_ch, i_index, j_index, - & kpdtg3, tg3, 1, len, me) - endif - endif -! -! vegetation type -! -! when using the new gldas soil moisture climatology, a veg type -! dataset must be selected. -! - if(fnvetc(1:8).ne.' ') then - if ( index(fnvetc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, - & vet,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - landice_cat=13 - if (maxval(vet)> 13.0) landice_cat=15 - else - call fixrdc_tile(fnvetc, tile_num_ch, i_index, j_index, - & kpdvet, vet, 1, len, me) - landice_cat=15 - endif - if (me .eq. 0) write(6,*) 'climatological vegetation', - & ' type read in.' - elseif(index(fnsmcc,'soilmgldas') /= 0) then ! new soil moisture climo - if (me .eq. 0) write(6,*) 'fatal error: must choose' - if (me .eq. 0) write(6,*) 'climatological veg type when' - if (me .eq. 0) write(6,*) 'using new gldas soil moisture.' - call abort - endif -! -! soil type -! - if(fnsotc(1:8).ne.' ') then - if ( index(fnsotc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, - & sot,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnsotc, tile_num_ch, i_index, j_index, - & kpdsot, sot, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological soil type read in.' - endif - -! -! min vegetation cover -! - if(fnvmnc(1:8).ne.' ') then - if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, - & vmn,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvmnc, tile_num_ch, i_index, j_index, - & 257, vmn, 99, len, me) - - endif - if (me .eq. 0) write(6,*) 'climatological shdmin read in.' - endif -! -! max vegetation cover -! - if(fnvmxc(1:8).ne.' ') then - if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, - & vmx,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvmxc, tile_num_ch, i_index, j_index, - & 256, vmx, 99, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological shdmax read in.' - endif -! -! slope type -! - if(fnslpc(1:8).ne.' ') then - if ( index(fnslpc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, - & slp,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnslpc, tile_num_ch, i_index, j_index, - & kpdslp, slp, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological slope read in.' - endif -! -! max snow albeod -! - if(fnabsc(1:8).ne.' ') then - if ( index(fnabsc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, - & absm,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index, - & kpdabs, absm, 1, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological snoalb read in.' - endif -!clu ---------------------------------------------------------------------- -! - is1 = sea1/3 + 1 - is2 = sea2/3 + 1 - if (is1 .eq. 5) is1 = 1 - if (is2 .eq. 5) is2 = 1 - do nn=1,2 -! -! seasonal mean climatology - if(nn.eq.1) then - isx=is1 - else - isx=is2 - endif - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 -! -! seasonal mean climatology -! -! albedo -! there are four albedo fields in this version: -! two for strong zeneith angle dependent (visible and near ir) -! and two for weak zeneith angle dependent (vis ans nir) -! - if (ialb == 0) then - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - endif -! -! monthly mean climatology -! - mon = mon1 - if (nn .eq. 2) mon = mon2 -!cbosu -!cbosu new snowfree albedo database is monthly. - if (ialb == 1) then - if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - else - do k = 1, 4 - call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, - & kpdalb(k), alb(:,k,nn), mon, len, me) - enddo - endif - endif - -! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2 -! -! tsf at the current time t -! - kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn -! -! tsf...at time t-deltsfc -! -! fh2 = fh - deltsfc -! if (fh2 .gt. 0.0) then -! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, -! & iy,im,id,ih,fh2,tsfcl2,len,iret -! &, imsk, jmsk, slmskh, gaus,blno, blto -! &, outlat, outlon, me) -! else -! do i=1,len -! tsfcl2(i) = tsfclm(i) -! enddo -! endif -! -! soil wetness -! - if(fnwetc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, - & wet(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnsmcc(1:8).ne.' ') then - if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data - kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, - & smc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - smc(i,l,nn) = smc(i,lsoil,nn) - enddo - enddo - else ! the new gldas data. it does not have data defined at landice - ! points. so for efficiency, don't have fixrdc try to - ! find a value at landice points as defined by the vet type (vet). - allocate(slmask_noice(len)) - slmask_noice=1.0 - do i = 1, len - if (nint(vet(i)) < 1 .or. - & nint(vet(i)) == landice_cat) then - slmask_noice(i) = 0.0 - endif - enddo - do k = 1, lsoil - if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) - if (k==2) kpd7=2600 ! 10_40 cm - if (k==3) kpd7=10340 ! 40_100 cm - if (k==4) kpd7=25800 ! 100_200 cm - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, - & smc(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - deallocate(slmask_noice) - endif - else - write(6,*) 'climatological soil wetness file not given' - call abort - endif -! -! soil temperature -! - if(fnstcc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, - & stc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - stc(i,l,nn) = stc(i,lsoil,nn) - enddo - enddo - endif -! -! sea ice -! - kpd7=-1 - if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, - & acn(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, - & ais(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - write(6,*) 'climatological ice cover file not given' - call abort - endif -! -! snow depth -! - kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, - & sno(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! snow cover -! - if(fnscvc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, - & scv(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - write(6,*) 'climatological snow cover read in.' - endif -! -! surface roughness -! - if(fnzorc(1:3) == 'sib') then - if (me == 0) then - write(6,*) 'roughness length to be set from sib veg type' - endif - elseif(fnzorc(1:4) == 'igbp') then - if (me == 0) then - write(6,*) 'roughness length to be set from igbp veg type' - endif - else - kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, - & zor(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -! - do i = 1, len -! set clouds climatology to zero - cvclm (i) = 0. - cvbclm(i) = 0. - cvtclm(i) = 0. -! - cnpclm(i) = 0. !set canopy water content climatology to zero - enddo -! -! vegetation cover -! - if(fnvegc(1:8).ne.' ') then - if ( index(fnvegc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, - & veg(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, - & kpdveg, veg(:,nn), mon, len, me) - endif - if (me .eq. 0) write(6,*) 'climatological vegetation', - & ' cover read in for mon=',mon - endif - - enddo -! - mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2 -! - if (me .eq. 0) print *,' mon1s=',mon1s,' mon2s=',mon2s - &,' sea1s=',sea1s,' sea2s=',sea2s -! - k1 = 1 ; k2 = 2 - m1 = 1 ; m2 = 2 -! - first = .false. - endif first_time -! -! to get tsf climatology at the previous call to sfccycle -! -! if (fh-deltsfc >= 0.0) then - rjdayh = rjday - deltsfc/24.0 -! else -! rjdayh = rjday -! endif -! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2=' -! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2 - if (rjdayh .ge. dayhf(mon1)) then - if (mon2 .eq. 1) mon2 = 13 - wei1x = (dayhf(mon2)-rjdayh)/(dayhf(mon2)-dayhf(mon1)) - wei2x = 1.0 - wei1x - if (mon2 .eq. 13) mon2 = 1 - else - rjdayh2 = rjdayh - if (rjdayh .lt. dayhf(1)) rjdayh2 = rjdayh2 + 365.0 - if (mon1s .eq. mon1) then - mon1s = mon1 - 1 - if (mon1s .eq. 0) mon1s = 12 - k2 = k1 - k1 = mod(k2,2) + 1 - mon = mon1s - kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,k1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif - mon2s = mon1s + 1 -! if (mon2s .eq. 1) mon2s = 13 - wei1x = (dayhf(mon2s)-rjdayh2)/(dayhf(mon2s)-dayhf(mon1s)) - wei2x = 1.0 - wei1x - if (mon2s .eq. 13) mon2s = 1 - do i=1,len - tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) - enddo - endif -! -!cbosu new albedo is monthly - if (sea1 .ne. sea1s) then - sea1s = sea1 - sea2s = sea2 - m1 = mod(m1,2) + 1 - m2 = mod(m1,2) + 1 -! -! seasonal mean climatology -! - isx = sea2/3 + 1 - if (isx .eq. 5) isx = 1 - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 -! -! albedo -! there are four albedo fields in this version: -! two for strong zeneith angle dependent (visible and near ir) -! and two for weak zeneith angle dependent (vis ans nir) -! -!cbosu - if (ialb == 0) then - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask - &, alb(1,k,m2),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - endif - - endif - - if (mon1 .ne. mon1s) then - - mon1s = mon1 - mon2s = mon2 - k1 = mod(k1,2) + 1 - k2 = mod(k1,2) + 1 -! -! monthly mean climatology -! - mon = mon2 - nn = k2 -!cbosu - if (ialb == 1) then - if (me == 0) print*,'bosu 2nd time in clima for month ', - & mon, k1,k2 - if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, - & alb(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - else - do k = 1, 4 - call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, - & kpdalb(k), alb(:,k,nn), mon, len, me) - enddo - endif - endif -! -! tsf at the current time t -! - kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, - & tsf(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! soil wetness -! - if(fnwetc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, - & wet(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnsmcc(1:8).ne.' ') then - if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data - kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, - & smc(1,lsoil,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - do l=1,lsoil-1 - do i = 1, len - smc(i,l,nn) = smc(i,lsoil,nn) - enddo - enddo - else ! the new gldas data. it does not have data defined at landice - ! points. so for efficiency, don't have fixrdc try to - ! find a value at landice points as defined by the vet type (vet). - allocate(slmask_noice(len)) - slmask_noice=1.0 - do i = 1, len - if (nint(vet(i)) < 1 .or. - & nint(vet(i)) == landice_cat) then - slmask_noice(i) = 0.0 - endif - enddo - do k = 1, lsoil - if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) - if (k==2) kpd7=2600 ! 10_40 cm - if (k==3) kpd7=10340 ! 40_100 cm - if (k==4) kpd7=25800 ! 100_200 cm - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, - & smc(1,k,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - enddo - deallocate(slmask_noice) - endif - else - write(6,*) 'climatological soil wetness file not given' - call abort - endif -! -! sea ice -! - kpd7=-1 - if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, - & acn(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - elseif(fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, - & ais(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - write(6,*) 'climatological ice cover file not given' - call abort - endif -! -! snow depth -! - kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, - & sno(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) -! -! snow cover -! - if(fnscvc(1:8).ne.' ') then - kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, - & scv(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - write(6,*) 'climatological snow cover read in.' - endif -! -! surface roughness -! - if(fnzorc(1:3) == 'sib') then - if (me == 0) then - write(6,*) 'roughness length to be set from sib veg type' - endif - elseif(fnzorc(1:4) == 'igbp') then - if (me == 0) then - write(6,*) 'roughness length to be set from igbp veg type' - endif - else - kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, - & zor(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif -! -! vegetation cover -! - if(fnvegc(1:8).ne.' ') then - if ( index(fnvegc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, - & veg(1,nn),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - else - call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, - & kpdveg, veg(:,nn), mon, len, me) - endif -! if (me .eq. 0) write(6,*) 'climatological vegetation', -! & ' cover read in for mon=',mon - endif -! - endif -! -! now perform the time interpolation -! -! when chosen, set the z0 based on the vegetation type. -! for this option to work, namelist variable fnvetc must be -! set to point at the proper vegetation type file. - if(fnzorc(1:3) == 'sib') then - if(fnvetc(1:4) == ' ') then - if (me==0) write(6,*) "must choose sib veg type climo file" - call abort - endif - zorclm = 0.0 - do i=1,len - ivtyp=nint(vet(i)) - if (ivtyp >= 1 .and. ivtyp <= 13) then - zorclm(i) = z0_sib(ivtyp) - endif - enddo - elseif(fnzorc(1:4) == 'igbp') then - if(fnvetc(1:4) == ' ') then - if (me==0) write(6,*) "must choose igbp veg type climo file" - call abort - endif - zorclm = 0.0 - do i=1,len - ivtyp=nint(vet(i)) - if (ivtyp >= 1 .and. ivtyp <= 20) then - z0_season(1) = z0_igbp_min(ivtyp) - z0_season(7) = z0_igbp_max(ivtyp) - if(outlat(i) < 0.0)then - zorclm(i) = wei1y * z0_season(hyr2) + - & wei2y *z0_season(hyr1) - else - zorclm(i) = wei1y * z0_season(hyr1) + - & wei2y *z0_season(hyr2) - endif - endif - enddo - else - do i=1,len - zorclm(i) = wei1m * zor(i,k1) + wei2m * zor(i,k2) - enddo - endif -! - do i=1,len - tsfclm(i) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2) - snoclm(i) = wei1m * sno(i,k1) + wei2m * sno(i,k2) - cvclm(i) = 0.0 - cvbclm(i) = 0.0 - cvtclm(i) = 0.0 - cnpclm(i) = 0.0 - tsfcl2(i) = tsf2(i) - enddo -! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m -! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) -! - if (fh .eq. 0.0) then - do i=1,len - tsfcl0(i) = tsfclm(i) - enddo - endif - if (rjdayh .ge. dayhf(mon1)) then - do i=1,len - tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) - tsfcl2(i) = tsf2(i) - enddo - endif -! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x -! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) -! &,' mon1s=',mon1s,' mon2s=',mon2s -! &,' slmask=',slmask(iprnt) -! - if(fnacnc(1:8).ne.' ') then - do i=1,len - acnclm(i) = wei1m * acn(i,k1) + wei2m * acn(i,k2) - enddo - elseif(fnaisc(1:8).ne.' ') then - do i=1,len - aisclm(i) = wei1m * ais(i,k1) + wei2m * ais(i,k2) - enddo - endif -! - if(fnwetc(1:8).ne.' ') then - do i=1,len - wetclm(i) = wei1m * wet(i,k1) + wei2m * wet(i,k2) - enddo - elseif(fnsmcc(1:8).ne.' ') then - do k=1,lsoil - do i=1,len - smcclm(i,k) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2) - enddo - enddo - endif -! - if(fnscvc(1:8).ne.' ') then - do i=1,len - scvclm(i) = wei1m * scv(i,k1) + wei2m * scv(i,k2) - enddo - endif -! - if(fntg3c(1:8).ne.' ') then - do i=1,len - tg3clm(i) = tg3(i) - enddo - elseif(fnstcc(1:8).ne.' ') then - do k=1,lsoil - do i=1,len - stcclm(i,k) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2) - enddo - enddo - endif -! - if(fnvegc(1:8).ne.' ') then - do i=1,len - vegclm(i) = wei1m * veg(i,k1) + wei2m * veg(i,k2) - enddo - endif -! - if(fnvetc(1:8).ne.' ') then - do i=1,len - vetclm(i) = vet(i) - enddo - endif -! - if(fnsotc(1:8).ne.' ') then - do i=1,len - sotclm(i) = sot(i) - enddo - endif - - -!clu ---------------------------------------------------------------------- -! - if(fnvmnc(1:8).ne.' ') then - do i=1,len - vmnclm(i) = vmn(i) - enddo - endif -! - if(fnvmxc(1:8).ne.' ') then - do i=1,len - vmxclm(i) = vmx(i) - enddo - endif -! - if(fnslpc(1:8).ne.' ') then - do i=1,len - slpclm(i) = slp(i) - enddo - endif -! - if(fnabsc(1:8).ne.' ') then - do i=1,len - absclm(i) = absm(i) - enddo - endif -!clu ---------------------------------------------------------------------- -! -!cbosu diagnostic print - if (me == 0) print*,'monthly albedo weights are ', - & wei1m,' for k', k1, wei2m, ' for k', k2 - - if (ialb == 1) then - do k=1,4 - do i=1,len - albclm(i,k) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2) - enddo - enddo - else - do k=1,4 - do i=1,len - albclm(i,k) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2) - enddo - enddo - endif -! - do k=1,2 - do i=1,len - alfclm(i,k) = alf(i,k) - enddo - enddo -! -! end of climatology reads -! - return - end subroutine clima - -!>\ingroup mod_sfcsub - subroutine fixrdc_tile(filename_raw, tile_num_ch, - & i_index, j_index, kpds, - & var, mon, npts, me) - use netcdf - use machine , only : kind_io8 - implicit none - character(len=*), intent(in) :: filename_raw - character(len=*), intent(in) :: tile_num_ch - integer, intent(in) :: npts, me, kpds, mon - integer, intent(in) :: i_index(npts) - integer, intent(in) :: j_index(npts) - real(kind_io8), intent(out) :: var(npts) - character(len=500) :: filename - character(len=80) :: errmsg - integer :: i, ii, ncid, t - integer :: error, id_dim - integer :: nx, ny, num_times - integer :: id_var - real(kind=4), allocatable :: dummy(:,:,:) - ii=index(filename_raw,"tileX") - - do i = 1, len(filename) - filename(i:i) = " " - enddo - - filename = filename_raw(1:ii-1) // tile_num_ch // ".nc" - - if (me == 0) print*, ' in fixrdc_tile for mon=',mon, - & ' filename=', trim(filename) - - error=nf90_open(trim(filename), nf90_nowrite, ncid) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'nx', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=nx) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'ny', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=ny) - if (error /= nf90_noerr) call netcdf_err(error) - - error=nf90_inq_dimid(ncid, 'time', id_dim) - if (error /= nf90_noerr) call netcdf_err(error) - error=nf90_inquire_dimension(ncid,id_dim,len=num_times) - if (error /= nf90_noerr) call netcdf_err(error) - - select case (kpds) - case(11) - error=nf90_inq_varid(ncid, 'substrate_temperature', id_var) - case(87) - error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) - case(159) - error=nf90_inq_varid(ncid, 'maximum_snow_albedo', id_var) - case(189) - error=nf90_inq_varid(ncid, 'visible_black_sky_albedo', id_var) - case(190) - error=nf90_inq_varid(ncid, 'visible_white_sky_albedo', id_var) - case(191) - error=nf90_inq_varid(ncid, 'near_IR_black_sky_albedo', id_var) - case(192) - error=nf90_inq_varid(ncid, 'near_IR_white_sky_albedo', id_var) - case(214) - error=nf90_inq_varid(ncid, 'facsf', id_var) - case(224) - error=nf90_inq_varid(ncid, 'soil_type', id_var) - case(225) - error=nf90_inq_varid(ncid, 'vegetation_type', id_var) - case(236) - error=nf90_inq_varid(ncid, 'slope_type', id_var) - case(256:257) - error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) - case default - print*,'fatal error in fixrdc_tile of sfcsub.F.' - print*,'unknown variable.' - call abort - end select - if (error /= nf90_noerr) call netcdf_err(error) - - allocate(dummy(nx,ny,1)) - - if (kpds == 256) then ! max veg greenness - - var = -9999. - do t = 1, num_times - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - do ii = 1,npts - var(ii) = max(var(ii), dummy(i_index(ii),j_index(ii),1)) - enddo - enddo - - elseif (kpds == 257) then ! min veg greenness - - var = 9999. - do t = 1, num_times - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - do ii = 1, npts - var(ii) = min(var(ii), dummy(i_index(ii),j_index(ii),1)) - enddo - enddo - - else - - error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,mon/), - & count=(/nx,ny,1/) ) - if (error /= nf90_noerr) call netcdf_err(error) - - do ii = 1, npts - var(ii) = dummy(i_index(ii),j_index(ii),1) - enddo - - endif - - deallocate(dummy) - - error=nf90_close(ncid) - - select case (kpds) - case(159) ! max snow alb - var = var * 100.0 - case(214) ! facsf - where (var < 0.0) var = 0.0 - var = var * 100.0 - case(189:192) - var = var * 100.0 - case(256:257) - var = var * 100.0 - end select - - return - - end subroutine fixrdc_tile - -!>\ingroup mod_sfcsub - subroutine netcdf_err(error) - - use netcdf - implicit none - - integer,intent(in) :: error - character(len=256) :: errmsg - - errmsg = nf90_strerror(error) - print*,'fatal error in sfcsub.F: ', trim(errmsg) - call abort - - end subroutine netcdf_err - -!>\ingroup mod_sfcsub - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, - & gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami - &, jj,w3kindreal,w3kindint - real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto -! -! read in grib climatology files and interpolate to the input -! grid. grib files should allow all the necessary parameters -! to be extracted from the description records. -! -! - character*500 fngrib -! character*80 fngrib, asgnstr -! - real (kind=kind_io8) slmskh(imsk,jmsk) -! - real (kind=kind_io8) gdata(len), slmask(len) - real (kind=kind_io8), allocatable :: data(:,:), rslmsk(:,:) - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) - real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) -! - logical lmask, yr2kc, gaus, ijordr - logical*1, allocatable :: lbms(:) -! - integer, intent(in) :: kpds7 - integer kpds(1000),kgds(1000) - integer jpds(1000),jgds(1000), kpds0(1000) - real (kind=kind_io8) outlat(len), outlon(len) -! - allocate(data8(1:mdata)) - allocate(lbms(mdata)) -! -! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv -! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/ -! &, kpds1_sv/-1/ -! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv -! &, rlngrb, rltgrb -! - iret = 0 -! - if (me .eq. 0) write(6,*) ' in fixrdc for mon=',mon - &,' fngrib=',trim(fngrib) -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb -! - lugi = 0 -! - lskip = -1 - jpds = -1 - jgds = -1 - jpds(5) = kpds5 - jpds(7) = kpds7 - kpds = jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - if (me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif - yr2kc = (kpds(8) / 100) .gt. 0 - kpds0 = jpds - kpds0(4) = -1 - kpds0(18) = -1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if (iret==99) write(6,*) ' field not found.' - call abort - endif -! -! handling climatology file -! - lskip = -1 - n = 0 - jpds = kpds0 - jpds(9) = mon - if(jpds(9).eq.13) jpds(9) = 1 - call w3kind(w3kindreal,w3kindint) - if (w3kindreal==8) then - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - else if (w3kindreal==4) then - allocate(data4(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) write(6,*) ' input grib file dates=', - & (kpds(i),i=8,11) - if(jret.eq.0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - imax=kgds(2) - jmax=kgds(3) - ijmax=imax*jmax - allocate (data(imax,jmax)) - do j=1,jmax - jj = (j-1)*imax - do i=1,imax - data(i,j) = data8(jj+i) - enddo - enddo - if (me .eq. 0) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax - else - write(6,*) ' error in getgb - jret=', jret - call abort - endif -! -! if (me == 0) then -! write(6,*) ' maxmin of input as is' -! kmami=1 -! call maxmin(data(1,1),ijmax,kmami) -! endif -! - call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me == 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat - endif - call subst(data,imax,jmax,dlon,dlat,ijordr) -! -! first get slmask over input grid -! - allocate (rlngrb(imax), rltgrb(jmax)) - allocate (rslmsk(imax,jmax)) - - call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, - & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk - &, gaus,blno, blto, kgds(1), kpds(4), lbms) -! write(6,*) ' kpds5=',kpds5,' lmask=',lmask -! - inttyp = 0 - if(kpds5.eq.225) inttyp = 1 - if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.236) inttyp = 1 - if(kpds5.eq.224) inttyp = 1 - if (me .eq. 0) then - if(inttyp.eq.1) print *, ' nearest grid point used' - &, ' kpds5=',kpds5, ' lmask = ',lmask - endif -! - call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, - & gdata,len,lmask,rslmsk,slmask - &, outlat, outlon,me) -! - deallocate (rlngrb, stat=iret) - deallocate (rltgrb, stat=iret) - deallocate (data, stat=iret) - deallocate (rslmsk, stat=iret) - call baclose(lugb,iret) -! - deallocate(data8) - deallocate(lbms) - return - end subroutine fixrdc - -!>\ingroup mod_sfcsub - subroutine fixrda(lugb,fngrib,kpds5,slmask, - & iy,im,id,ih,fh,gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : mdata - implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, - & rjday,blto -! -! read in grib climatology/analysis files and interpolate to the input -! dates and the grid. grib files should allow all the necessary parameters -! to be extracted from the description records. -! -! nrepmx: max number of days for going back date search -! nvalid: analysis later than (current date - nvalid) is regarded as -! valid for current analysis -! - parameter(nrepmx=15, nvalid=4) -! - character*500 fngrib -! character*80 fngrib, asgnstr -! - real (kind=kind_io8) slmskh(imsk,jmsk) -! - real (kind=kind_io8) gdata(len), slmask(len) - real (kind=kind_io8), allocatable :: data(:,:),rslmsk(:,:) - real (kind=kind_io8), allocatable :: data8(:) - real (kind=kind_io4), allocatable :: data4(:) - real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) -! - logical lmask, yr2kc, gaus, ijordr - logical*1 lbms(mdata) -! - integer kpds(1000),kgds(1000) - integer jpds(1000),jgds(1000), kpds0(1000) - real (kind=kind_io8) outlat(len), outlon(len) -! -! dayhf : julian day of the middle of each month -! - real (kind=kind_io8) dayhf(13) - data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, - & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ -! -! mjday : number of days in a month -! - integer mjday(12) - data mjday/31,28,31,30,31,30,31,31,30,31,30,31/ -! - real (kind=kind_io8) fha(5) - real(4) fha4(5) - integer ida(8),jda(8) -! - allocate(data8(1:mdata)) - iret = 0 - monend = 9999 -! -! compute jy,jm,jd,jh of forecast and the day of the year -! - iy4=iy - if(iy.lt.101) iy4=1900+iy4 - fha=0 - ida=0 - jda=0 - fha(2)=nint(fh) - ida(1)=iy - ida(2)=im - ida(3)=id - ida(5)=ih - call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - fha4=fha - call w3movdat(fha4,ida,jda) - else - call w3movdat(fha,ida,jda) - endif - jy=jda(1) - jm=jda(2) - jd=jda(3) - jh=jda(5) -! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', -! & jy,jm,jd,jh,rjday - jdow = 0 - jdoy = 0 - jday = 0 - call w3doxdat(jda,jdow,jdoy,jday) - rjday=jdoy+jda(5)/24. - if(rjday.lt.dayhf(1)) rjday=rjday+365. - - if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me .eq. 0) then - write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh -! - write(6,*) ' ' - write(6,*) '************************************************' - endif -! - close(lugb) - call baopenr(lugb,fngrib,iret) - if (iret .ne. 0) then - write(6,*) ' error in opening file ',trim(fngrib) - print *,'error in opening file ',trim(fngrib) - call abort - endif - if (me .eq. 0) write(6,*) ' file ',trim(fngrib), - & ' opened. unit=',lugb -! - lugi = 0 -! - lskip=-1 - jpds=-1 - jgds=-1 - jpds(5)=kpds5 - kpds = jpds - call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, - & lskip,kpds,kgds,iret) - if (me .eq. 0) then - write(6,*) ' first grib record.' - write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) - write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) - write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) - endif - yr2kc = (kpds(8) / 100) .gt. 0 - kpds0=jpds - kpds0(4)=-1 - kpds0(18)=-1 - if(iret.ne.0) then - write(6,*) ' error in getgbh. iret: ', iret - if(iret==99) write(6,*) ' field not found.' - call abort - endif -! -! handling analysis file -! -! find record for the given hour/day/month/year -! - nrept=0 - jpds=kpds0 - lskip = -1 - iyr=jy - if(iyr.le.100) iyr=2050-mod(2050-iyr,100) - imo=jm - idy=jd - ihr=jh -! year 2000 compatible data - if (yr2kc) then - jpds(8) = iyr - else - jpds(8) = mod(iyr,1900) - endif - 50 continue - jpds( 8)=mod(iyr-1,100)+1 - jpds( 9)=imo - jpds(10)=idy -! jpds(11)=ihr - jpds(21)=(iyr-1)/100+1 - call w3kind(w3kindreal,w3kindint) - if (w3kindreal == 8) then - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data8,jret) - elseif (w3kindreal == 4) then - allocate (data4(1:mdata)) - call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, - & kpds,kgds,lbms,data4,jret) - data8 = real(data4, kind=kind_io8) - deallocate(data4) - endif - if (me .eq. 0) write(6,*) ' input grib file dates=', - & (kpds(i),i=8,11) - if(jret.eq.0) then - if(ndata.eq.0) then - write(6,*) ' error in getgb' - write(6,*) ' kpds=',kpds - write(6,*) ' kgds=',kgds - call abort - endif - imax=kgds(2) - jmax=kgds(3) - ijmax=imax*jmax - allocate (data(imax,jmax)) - do j=1,jmax - jj = (j-1)*imax - do i=1,imax - data(i,j) = data8(jj+i) - enddo - enddo - else - if(nrept.eq.0) then - if (me .eq. 0) then - write(6,*) ' no matching dates found. start searching', - & ' nearest matching dates (going back).' - endif - endif -! -! no matching ih found. search nearest hour -! - if(ihr.eq.6) then - ihr=0 - go to 50 - elseif(ihr.eq.12) then - ihr=0 - go to 50 - elseif(ihr.eq.18) then - ihr=12 - go to 50 - elseif(ihr.eq.0.or.ihr.eq.-1) then - idy=idy-1 - if(idy.eq.0) then - imo=imo-1 - if(imo.eq.0) then - iyr=iyr-1 - if(iyr.lt.0) iyr=99 - imo=12 - endif - idy=31 - if(imo.eq.4.or.imo.eq.6.or.imo.eq.9.or.imo.eq.11) idy=30 - if(imo.eq.2) then - if(mod(iyr,4).eq.0) then - idy=29 - else - idy=28 - endif - endif - endif - ihr=-1 - if (me .eq. 0) write(6,*) ' decremented dates=', - & iyr,imo,idy,ihr - nrept=nrept+1 - if(nrept.gt.nvalid) iret=-1 - if(nrept.gt.nrepmx) then - if (me .eq. 0) then - write(6,*) ' searching range exceeded.' - &, ' may be wrong grib file given' - write(6,*) ' fngrib=',trim(fngrib) - write(6,*) ' terminating search and', - & ' and setting gdata to -999' - write(6,*) ' range max=',nrepmx - endif -! imax=kgds(2) -! jmax=kgds(3) -! ijmax=imax*jmax -! do ij=1,ijmax -! data(ij)=0. -! enddo - go to 100 - endif - go to 50 - else - if (me .eq. 0) then - write(6,*) ' search of analysis for ihr=',ihr,' failed.' - write(6,*) ' kpds=',kpds - write(6,*) ' iyr,imo,idy,ihr=',iyr,imo,idy,ihr - endif - go to 100 - endif - endif -! - 80 continue -! if (me == 0) then -! write(6,*) ' maxmin of input as is' -! kmami=1 -! call maxmin(data(1,1),ijmax,kmami) -! endif -! - call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me == 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat - endif - call subst(data,imax,jmax,dlon,dlat,ijordr) -! -! first get slmask over input grid -! - allocate (rlngrb(imax), rltgrb(jmax)) - allocate (rslmsk(imax,jmax)) - call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, - & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk -! & data,imax,jmax,abs(dlon),abs(dlat),lmask,rslmsk -!cggg &, gaus,blno, blto, kgds(1)) - &, gaus,blno, blto, kgds(1), kpds(4), lbms) - -! write(6,*) ' kpds5=',kpds5,' lmask=',lmask -! - inttyp = 0 - if(kpds5.eq.225) inttyp = 1 - if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.66) inttyp = 1 - if(inttyp.eq.1) print *, ' nearest grid point used' -! - call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, - & gdata,len,lmask,rslmsk,slmask - &, outlat, outlon, me) -! - deallocate (rlngrb, stat=iret) - deallocate (rltgrb, stat=iret) - deallocate (data, stat=iret) - deallocate (rslmsk, stat=iret) - call baclose(lugb,iret2) -! write(6,*) ' ' - deallocate(data8) - return -! - 100 continue - iret=1 - do i=1,len - gdata(i) = -999. - enddo -! - call baclose(lugb,iret2) -! - deallocate(data8) - return - end subroutine fixrda - -!>\ingroup mod_sfcsub - subroutine snodpth2(glacir,snwmax,snoanl, len, me) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,me,len - real (kind=kind_io8) snwmax -! - real (kind=kind_io8) snoanl(len), glacir(len) -! - if (me .eq. 0) write(6,*) 'snodpth2' -! - do i=1,len -! -! if glacial points has snow in climatology, set sno to snomax -! - if(glacir(i).ne.0..and.snoanl(i).lt.snwmax*0.5) then - snoanl(i) = snwmax + snoanl(i) - endif -! - enddo - return - end -!>@} diff --git a/physics/shinhongvdif.F90 b/physics/shinhongvdif.F90 deleted file mode 100644 index c5011218b..000000000 --- a/physics/shinhongvdif.F90 +++ /dev/null @@ -1,2106 +0,0 @@ -!> \file shinhongvdif.F90 -!! This file contains the CCPP-compliant Shinhong (saYSU) scheme which computes -!! subgrid vertical turbulence mixing using traditional K-profile method -!! Please refer to (Shin and Hong, 2013,2015). -!! -!! Subroutine 'shinhongvdif_run' computes subgrid vertical turbulence mixing -!! using scale-aware YSU K-profile method -!! -!---------------------------------------------------------------------- - - module shinhongvdif - contains - - subroutine shinhongvdif_init () - end subroutine shinhongvdif_init - - subroutine shinhongvdif_finalize () - end subroutine shinhongvdif_finalize - -!> \defgroup SHINHONG FV3GFS shinhongvdif_run Main -!! \brief This subroutine contains all of the logic for the -!! scale-aware Shinhong scheme. -!! -!> \section arg_table_shinhongvdif_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | -!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | -!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | -!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | -!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | -!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | -!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | -!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | -!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | -!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | -!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | -!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | -!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | -!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | -!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | -!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!------------------------------------------------------------------------------- - subroutine shinhongvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & - utnp,vtnp,ttnp,qtnp,ntrac,ndiff,ntcw,ntiw, & - phii,phil,psfcpa, & - zorl,stress,hpbl,psim,psih, & - landmask,heat,evap,wspd,br, & - g,rd,cp,rv,ep1,ep2,xlv, & - dusfc,dvsfc,dtsfc,dqsfc, & - dt,kpbl1d, & - u10,v10, & - dx,errmsg,errflg ) - - use machine , only : kind_phys -! -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! -! the shinhongpbl (shin and hong 2015) is based on the les study of shin -! and hong (2013). the major ingredients of the shinhongpbl are -! 1) the prescribed nonlocal heat transport profile fit to the les and -! 2) inclusion of explicit scale dependency functions for vertical -! transport in convective pbl. -! so, the shinhongpbl works at the gray zone resolution of convective pbl. -! note that honnert et al. (2011) first suggested explicit scale dependency -! function, and shin and hong (2013) further classified the function by -! stability (u*/w*) in convective pbl and calculated the function for -! nonlocal and local transport separately. -! vertical mixing in the stable boundary layer and free atmosphere follows -! hong (2010) and hong et al. (2006), same as the ysupbl scheme. -! -! shinhongpbl: -! coded and implemented by hyeyum hailey shin (ncar) -! summer 2014 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! references: -! shin and hong (2015) mon. wea. rev. -! shin and hong (2013) j. atmos. sci. -! honnert, masson, and couvreux (2011) j. atmos. sci. -! hong (2010) quart. j. roy. met. soc -! hong, noh, and dudhia (2006), mon. wea. rev. -! -!------------------------------------------------------------------------------- -! - real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 - real(kind=kind_phys),parameter :: 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 :: ckz = 0.001,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 - real(kind=kind_phys),parameter :: karman = 0.4 - real(kind=kind_phys),parameter :: corf=0.000073 - real(kind=kind_phys),parameter :: rcl = 1.0 - integer,parameter :: imvdif = 1 - integer,parameter :: shinhong_tke_diag = 0 -! -! tunable parameters for tke -! - real(kind=kind_phys),parameter :: epsq2l = 0.01,c_1 = 1.0,gamcre = 0.224 -! -! tunable parameters for prescribed nonlocal transport profile -! - real(kind=kind_phys),parameter :: mltop = 1.0,sfcfracn1 = 0.075 - real(kind=kind_phys),parameter :: nlfrac = 0.7,enlfrac = -0.4 - real(kind=kind_phys),parameter :: a11 = 1.0,a12 = -1.15 - real(kind=kind_phys),parameter :: ezfac = 1.5 - real(kind=kind_phys),parameter :: cpent = -0.4,rigsmax = 100. - real(kind=kind_phys),parameter :: entfmin = 1.0, entfmax = 5.0 -! 1D in - integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw - real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt -! 3D in - real(kind=kind_phys), dimension(ix, km) , & - intent(in ) :: phil, & - pi2d, & - p2d, & - ux, & - vx, & - tx - real(kind=kind_phys), dimension( ix, km, ntrac ) , & - intent(in ) :: qx - - real(kind=kind_phys), dimension( ix, km+1 ) , & - intent(in ) :: p2di, & - phii -! 3D in&out - real(kind=kind_phys), dimension(im, km) , & - intent(inout) :: utnp, & - vtnp, & - ttnp - real(kind=kind_phys), dimension(im, km, ntrac ) , & - intent(inout) :: qtnp -! 2D in - integer, dimension(im) , & - intent(in ) :: landmask - - real(kind=kind_phys), dimension(im) , & - intent(in ) :: heat, & - evap, & - br, & - psim, & - psih, & - psfcpa, & - stress, & - zorl, & - wspd, & - u10, & - v10, & - dx -! 2D: out - integer, dimension(im) , & - intent(out ) :: kpbl1d - - real(kind=kind_phys), dimension(im) , & - intent(out ) :: hpbl, & - dusfc, & - dvsfc, & - dtsfc, & - dqsfc - -! error messages - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -! local vars -! - integer :: n,i,k,l,ic - integer :: klpbl - integer :: lmh,lmxl,kts,kte,its,ite -! - real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 - real(kind=kind_phys) :: ss,ri,qmean,tmean,alpha,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) :: delxy,pu1,pth1,pq1 - real(kind=kind_phys) :: dex,hgame_c - real(kind=kind_phys) :: zfacdx - real(kind=kind_phys) :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 - real(kind=kind_phys) :: mlfrac,ezfrac,sfcfracn - real(kind=kind_phys) :: uwst,uwstx,csfac - 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 -! - integer, dimension(im) :: kpbl - real(kind=kind_phys), dimension(im) :: hol - real(kind=kind_phys), dimension(im) :: deltaoh - real(kind=kind_phys), dimension(im) :: rigs, & - enlfrac2, & - cslen - real(kind=kind_phys), dimension(im) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - prpbl, & - wspd1, & - ust,hfx,qfx,znt, & - xland - real(kind=kind_phys), dimension(im) :: & - ust3, & - wstar3, & - wstar,delta, & - hgamu,hgamv, & - wm2, we, & - bfxpbl, & - hfxpbl,qfxpbl, & - ufxpbl,vfxpbl, & - dthvx - real(kind=kind_phys), dimension(im) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro - real(kind=kind_phys), dimension(im) :: & - efxpbl, & - hpbl_cbl, & - epshol, & - ct -! - real(kind=kind_phys), dimension(im,km) :: & - xkzm,xkzh, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - xkzq, & - zfac - real(kind=kind_phys), dimension(im,km) :: & - thx,thvx, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za - real(kind=kind_phys), dimension(im,km) :: & - wscalek - real(kind=kind_phys), dimension(im,km) :: & - xkzml,xkzhl, & - zfacent,entfac - real(kind=kind_phys), dimension(im,km) :: & - mf, & - zfacmf, & - entfacmf - real(kind=kind_phys), dimension(im,km) :: & - q2x, & - hgame2d, & - tflux_e, & - qflux_e, & - tvflux_e - real(kind=kind_phys), dimension( im, km+1 ) :: zq - real(kind=kind_phys), dimension( im, km, ndiff ) :: r3,f3 -! - real(kind=kind_phys), dimension( km ) :: & - uxk,vxk, & - txk,thxk,thvxk, & - q2xk, & - hgame - real(kind=kind_phys), dimension( km ) :: & - ps1d,pb1d,eps1d,pt1d, & - xkze1d,eflx_l1d,eflx_nl1d, & - ptke1 - real(kind=kind_phys), dimension( 2:km ) :: & - s2,gh,rig,el, & - akmk,akhk, & - mfk,ufxpblk,vfxpblk,qfxpblk - real(kind=kind_phys), dimension( km+1 ) :: zqk - - real(kind=kind_phys), dimension(im,km) :: dz8w2d -! - logical, dimension(im) :: pblflg, & - sfcflg, & - stable - logical, dimension( ndiff ) :: ifvmix -! -!------------------------------------------------------------------------------- -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - its = 1 - ite = im - kts = 1 - kte = km - - klpbl = kte - lmh = 1 - lmxl = 1 -! - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! change xland values - do i=its,ite - if(landmask(i).eq.0) then !ocean - xland(i) = 2 - else - xland(i) = 1 !land - end if - end do -! -! k-start index for cloud and rain -! - ifvmix(:) = .true. -! - do k = kts,kte - do i = its,ite - thx(i,k) = tx(i,k)/pi2d(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - tvcon = (1.+ep1*qx(i,k,1)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - do i = its,ite - tvcon = (1.+ep1*qx(i,1,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF - qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF - ust(i) = sqrt(stress(i)) ! reset to the variable in WRF - znt(i) = 0.01*zorl(i) ! reset to the variable in WRF - 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) = phii(i,k+1)*conw - za(i,k) = phil(i,k)*conw - enddo - enddo -! - do k = kts,kte - do i = its,ite - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - dz8w2d(i,k)=dzq(i,k) - 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 -! - do i = its,ite - wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 - enddo - -! write(0,*)"===CALLING shinhong; input:" -! print*,"t:",tx(1,1),tx(1,2),tx(1,km) -! print*,"u:",ux(1,1),ux(1,2),ux(1,km) -! print*,"v:",vx(1,1),vx(1,2),vx(1,km) -! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) -! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) -! print*,"dz8w2d:",dz8w2d(1,1),dz8w2d(1,2),dz8w2d(1,km) -! print *,"del:",del(1,1),del(1,2),del(1,km) -! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) -! print*,"phil:",za(1,1),za(1,2),za(1,km) -! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) -! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) -! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) -! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) -! print*,"rd,rv,g:",rd,rv,g -! print*,"ep1,ep2,xlv:",ep1,ep2,xlv -! print*,"br,psim,psih:",br(1),psim(1),psih(1) -! print*,"dx,u10,v10:",dx(1),u10(1),v10(1) -! print*,"psfcpa,cp:",psfcpa(1),cp -! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw -! -!---- 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 - enddo -! - do i = its,ite - efxpbl(i) = 0.0 - hpbl_cbl(i) = 0.0 - epshol(i) = 0.0 - ct(i) = 0.0 - enddo -! - do i = its,ite - deltaoh(i) = 0.0 - rigs(i) = 0.0 - enlfrac2(i) = 0.0 - cslen(i) = 0.0 - enddo -! - do k = kts,klpbl - do i = its,ite - wscalek(i,k) = 0.0 - enddo - enddo -! - do k = kts,klpbl - do i = its,ite - zfac(i,k) = 0.0 - enddo - enddo -! - do k = kts,kte - do i = its,ite - q2x(i,k) = 1.e-4 - enddo - enddo -! - do k = kts,kte - do i = its,ite - hgame2d(i,k) = 0.0 - tflux_e(i,k) = 0.0 - qflux_e(i,k) = 0.0 - tvflux_e(i,k) = 0.0 - enddo - enddo -! - do k = kts,kte - do i = its,ite - mf(i,k) = 0.0 - zfacmf(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) - hpbl_cbl(i) = zq(i,1) - zl1(i) = za(i,1) - thermal(i)= thvx(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 - epshol(i) = hol1 - 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) - 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 -! - 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. - uwst = abs(ust(i)/wstar(i)-0.5) - uwstx = -80.*uwst+14. - csfac = 0.5*(tanh(uwstx)+3.) - cslen(i) = csfac*hpbl(i) - endif - enddo -! -! stable boundary layer -! - do i = its,ite - hpbl_cbl(i) = hpbl(i) - 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 -! -! scale dependency for nonlocal momentum and moisture transport -! - do i = its,ite - pu1=pu(dx(i),cslen(i)) - pq1=pq(dx(i),cslen(i)) - if(pblflg(i)) then - hgamu(i) = hgamu(i)*pu1 - hgamv(i) = hgamv(i)*pu1 - hgamq(i) = hgamq(i)*pq1 - endif - enddo -! -! estimate the entrainment parameters -! - do i = its,ite - if(pblflg(i)) then - k = kpbl(i) - 1 - prpbl(i) = 1.0 - 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) - dthx = max(thx(i,k+1)-thx(i,k),tmin) - dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) - hfxpbl(i) = we(i)*dthx - pq1=pq(dx(i),cslen(i)) - qfxpbl(i) = we(i)*dqx*pq1 -! - pu1=pu(dx(i),cslen(i)) - 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*pu1,-ust(i)*ust(i)) - elseif(dux.lt.-tmin) then - ufxpbl(i) = min(prpbl(i)*we(i)*dux*pu1,ust(i)*ust(i)) - else - ufxpbl(i) = 0.0 - endif - if(dvx.gt.tmin) then - vfxpbl(i) = max(prpbl(i)*we(i)*dvx*pu1,-ust(i)*ust(i)) - elseif(dvx.lt.-tmin) then - vfxpbl(i) = min(prpbl(i)*we(i)*dvx*pu1,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.) - delb = govrth(i)*dthvx(i) - deltaoh(i) = d1*hpbl(i) + d2*wm2(i)/delb - deltaoh(i) = max(ezfac*deltaoh(i),hpbl(i)-za(i,kpbl(i)-1)-1.) - deltaoh(i) = min(deltaoh(i) ,hpbl(i)) - rigs(i) = govrth(i)*dthvx(i)*deltaoh(i)/(dux**2.+dvx**2.) - rigs(i) = max(min(rigs(i), rigsmax),rimin) - enlfrac2(i) = max(min(wm3/wstar3(i)/(1.+cpent/rigs(i)),entfmax), entfmin) - enlfrac2(i) = enlfrac2(i)*enlfrac - endif - enddo -! - do k = kts,klpbl - do i = its,ite - if(pblflg(i))then - entfacmf(i,k) = sqrt(((zq(i,k+1)-hpbl(i))/deltaoh(i))**2.) - endif - if(pblflg(i).and.k.ge.kpbl(i))then - entfac(i,k) = ((zq(i,k+1)-hpbl(i))/deltaoh(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 - if(sfcflg(i)) then - prfac = conpr - prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(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 - 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)) -! in cloud - if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then - if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3 & - .and.(qx(i,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3) then - qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) - tmean = 0.5*(tx(i,k)+tx(i,k+1)) - alpha = xlv*qmean/rd/tmean - chi = xlv*xlv*qmean/cp/rv/tmean/tmean - ri = (1.+alpha)*(ri-g*g/ss/tmean/cp*((chi-alpha)/(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 -! -! prescribe nonlocal heat transport below pbl -! - do i = its,ite - deltaoh(i) = deltaoh(i)/hpbl(i) - enddo -! - do i = its,ite - mlfrac = mltop-deltaoh(i) - ezfrac = mltop+deltaoh(i) - zfacmf(i,1) = min(max((zq(i,2)/hpbl(i)),zfmin),1.) - sfcfracn = max(sfcfracn1,zfacmf(i,1)) -! - sflux0 = (a11+a12*sfcfracn)*sflux(i) - snlflux0 = nlfrac*sflux0 - amf1 = snlflux0/sfcfracn - amf2 = -snlflux0/(mlfrac-sfcfracn) - bmf2 = -mlfrac*amf2 - amf3 = snlflux0*enlfrac2(i)/deltaoh(i) - bmf3 = -amf3*mlfrac - hfxpbl(i) = amf3+bmf3 - pth1=pthnl(dx(i),cslen(i)) - hfxpbl(i) = hfxpbl(i)*pth1 -! - do k = kts,klpbl - zfacmf(i,k) = max((zq(i,k+1)/hpbl(i)),zfmin) - if(pblflg(i).and.k.lt.kpbl(i)) then - if(zfacmf(i,k).le.sfcfracn) then - mf(i,k) = amf1*zfacmf(i,k) - else if (zfacmf(i,k).le.mlfrac) then - mf(i,k) = amf2*zfacmf(i,k)+bmf2 - endif - mf(i,k) = mf(i,k)+hfxpbl(i)*exp(-entfacmf(i,k)) - mf(i,k) = mf(i,k)*pth1 - 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.+hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = 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*(-mf(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 - al(i,k) = -dtodsu*dsdz2 -! -! scale dependency for local heat transport -! - zfacdx=0.2*hpbl(i)/zq(i,k+1) - delxy=dx(i)*max(zfacdx,1.0) - pth1=pthl(delxy,hpbl(i)) - if(pblflg(i).and.k.lt.kpbl(i)) then - au(i,k) = au(i,k)*pth1 - al(i,k) = al(i,k)*pth1 - endif - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - 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) - if(k.eq.kte) then - tflux_e(i,k) = ttend*dz8w2d(i,k) - else - tflux_e(i,k) = tflux_e(i,k+1) + ttend*dz8w2d(i,k) - endif - 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)+qfx(i)*g/del(i,1)*dt2 - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - do i = its,ite - f3(i,1,ic) = qx(i,1,ic) - 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 = dt2/del(i,k) - dtodsu = 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,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,1) - else - f3(i,k+1,1) = qx(i,k+1,1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 -! -! scale dependency for local moisture transport -! - zfacdx=0.2*hpbl(i)/zq(i,k+1) - delxy=dx(i)*max(zfacdx,1.0) - pq1=pq(delxy,hpbl(i)) - if(pblflg(i).and.k.lt.kpbl(i)) then - au(i,k) = au(i,k)*pq1 - al(i,k) = al(i,k)*pq1 - endif - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - do k = kts,kte-1 - do i = its,ite - f3(i,k+1,ic) = qx(i,k+1,ic) - enddo - enddo - enddo - endif -! -! 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,1))*rdt - qtnp(i,k,1) = qtnp(i,k,1)+qtend - dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - if(k.eq.kte) then - qflux_e(i,k) = qtend*dz8w2d(i,k) - else - qflux_e(i,k) = qflux_e(i,k+1) + qtend*dz8w2d(i,k) - endif - tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) - enddo - enddo -! print*,"qtnp:",maxval(qtnp(:,:,1)),minval(qtnp(:,:,1)) -! - do k = kts,kte - do i = its,ite - if(pblflg(i).and.k.lt.kpbl(i)) then - hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) - hgame_c=min(hgame_c,gamcre) - if(k.eq.kte)then - hgame2d(i,k)=hgame_c*0.5*tvflux_e(i,k)*hpbl(i) - hgame2d(i,k)=max(hgame2d(i,k),0.0) - else - hgame2d(i,k)=hgame_c*0.5*(tvflux_e(i,k)+tvflux_e(i,k+1))*hpbl(i) - hgame2d(i,k)=max(hgame2d(i,k),0.0) - endif - endif - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - if(ifvmix(ic)) then - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt - qtnp(i,k,ic) = qtnp(i,k,ic)+qtend - enddo - enddo - endif - 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 -! - do i = its,ite - ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - f1(i,1) = ux(i,1) - f2(i,1) = vx(i,1) - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = 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 - al(i,k) = -dtodsu*dsdz2 -! -! scale dependency for local momentum transport -! - zfacdx=0.2*hpbl(i)/zq(i,k+1) - delxy=dx(i)*max(zfacdx,1.0) - pu1=pu(delxy,hpbl(i)) - if(pblflg(i).and.k.lt.kpbl(i)) then - au(i,k) = au(i,k)*pu1 - al(i,k) = al(i,k)*pu1 - endif - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - 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 tridi1n(al,ad,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 -! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo -! -!---- calculate sgs tke which is consistent with shinhongpbl algorithm -! - if (shinhong_tke_diag.eq.1) then -! - tke_calculation: do i = its,ite - do k = kts+1,kte - s2(k) = 0.0 - gh(k) = 0.0 - rig(k) = 0.0 - el(k) = 0.0 - akmk(k) = 0.0 - akhk(k) = 0.0 - mfk(k) = 0.0 - ufxpblk(k) = 0.0 - vfxpblk(k) = 0.0 - qfxpblk(k) = 0.0 - enddo -! - do k = kts,kte - uxk(k) = 0.0 - vxk(k) = 0.0 - txk(k) = 0.0 - thxk(k) = 0.0 - thvxk(k) = 0.0 - q2xk(k) = 0.0 - hgame(k) = 0.0 - ps1d(k) = 0.0 - pb1d(k) = 0.0 - eps1d(k) = 0.0 - pt1d(k) = 0.0 - xkze1d(k) = 0.0 - eflx_l1d(k) = 0.0 - eflx_nl1d(k) = 0.0 - ptke1(k) = 1.0 - enddo -! - do k = kts,kte+1 - zqk(k) = 0.0 - enddo -! - do k = kts,kte - uxk(k) = ux(i,k) - vxk(k) = vx(i,k) - txk(k) = tx(i,k) - thxk(k) = thx(i,k) - thvxk(k) = thvx(i,k) - q2xk(k) = q2x(i,k) - hgame(k) = hgame2d(i,k) - enddo -! - do k = kts,kte-1 - if(pblflg(i).and.k.le.kpbl(i)) then - zfacdx = 0.2*hpbl(i)/za(i,k) - delxy = dx(i)*max(zfacdx,1.0) - ptke1(k+1) = ptke(delxy,hpbl(i)) - endif - enddo -! - do k = kts,kte+1 - zqk(k) = zq(i,k) - enddo -! - do k = kts+1,kte - akmk(k) = xkzm(i,k-1) - akhk(k) = xkzh(i,k-1) - mfk(k) = mf(i,k-1)/xkzh(i,k-1) - ufxpblk(k) = ufxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) - vfxpblk(k) = vfxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) - qfxpblk(k) = qfxpbl(i)*zfacent(i,k-1)/xkzq(i,k-1) - enddo -! - if(pblflg(i)) then - k = kpbl(i) - 1 - dex = 0.25*(q2xk(k+2)-q2xk(k)) - efxpbl(i) = we(i)*dex - endif -! -!---- find the mixing length -! - call mixlen(lmh,uxk,vxk,txk,thxk,qx(i,kts,1),qx(i,kts,ntcw) & - ,q2xk,zqk,ust(i),corf,epshol(i) & - ,s2,gh,rig,el & - ,hpbl(i),kpbl(i),lmxl,ct(i) & - ,hgamu(i),hgamv(i),hgamq(i),pblflg(i) & - ,mfk,ufxpblk,vfxpblk,qfxpblk & - ,ep1,karman,cp & - ,kts,kte ) -! -!---- solve for the production/dissipation of the turbulent kinetic energy -! - call prodq2(lmh,dt,ust(i),s2,rig,q2xk,el,zqk,akmk,akhk & - ,uxk,vxk,thxk,thvxk & - ,hgamu(i),hgamv(i),hgamq(i),dx(i) & - ,hpbl(i),pblflg(i),kpbl(i) & - ,mfk,ufxpblk,vfxpblk,qfxpblk & - ,ep1 & - ,kts,kte ) -! -! -!---- carry out the vertical diffusion of turbulent kinetic energy -! - call vdifq(lmh,dt,q2xk,el,zqk & - ,akhk,ptke1 & - ,hgame,hpbl(i),pblflg(i),kpbl(i) & - ,efxpbl(i) & - ,kts,kte ) -! -!---- save the new tke and mixing length. -! - do k = kts,kte - q2x(i,k) = amax1(q2xk(k),epsq2l) - enddo -! - enddo tke_calculation - endif -! -!---- end of tke calculation -! -! -!---- end of vertical diffusion -! - end subroutine shinhongvdif_run -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - 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, & - 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./cm(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./(cm(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./(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 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 tridi1n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - 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 - 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 - 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 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 mixlen(lmh,u,v,t,the,q,cwm,q2,z,ustar,corf,epshol, & - s2,gh,ri,el,hpbl,lpbl,lmxl,ct, & - hgamu,hgamv,hgamq,pblflg, & - mf,ufxpbl,vfxpbl,qfxpbl, & - p608,vkarman,cp, & - kts,kte) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- -! qnse model constants -!------------------------------------------------------------------------------- - real(kind=kind_phys),parameter :: blckdr=0.0063,cn=0.75 - real(kind=kind_phys),parameter :: eps1=1.e-12,epsl=0.32,epsru=1.e-7,epsrs=1.e-7 - real(kind=kind_phys),parameter :: el0max=1000.,el0min=1.,elfc=0.23*0.5 - real(kind=kind_phys),parameter :: alph=0.30,beta=1./273.,g=9.81,btg=beta*g - real(kind=kind_phys),parameter :: a1=0.659888514560862645,a2x=0.6574209922667784586 - real(kind=kind_phys),parameter :: b1=11.87799326209552761,b2=7.226971804046074028 - real(kind=kind_phys),parameter :: c1=0.000830955950095854396 - real(kind=kind_phys),parameter :: adnh= 9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg - real(kind=kind_phys),parameter :: adnm=18.*a1*a1*a2x*(b2-3.*a2x)*btg - real(kind=kind_phys),parameter :: bdnh= 3.*a2x*(7.*a1+b2)*btg,bdnm= 6.*a1*a1 -!------------------------------------------------------------------------------- -! free term in the equilibrium equation for (l/q)**2 -!------------------------------------------------------------------------------- - real(kind=kind_phys),parameter :: aeqh=9.*a1*a2x*a2x*b1*btg*btg & - +9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg - real(kind=kind_phys),parameter :: aeqm=3.*a1*a2x*b1*(3.*a2x+3.*b2*c1+18.*a1*c1-b2) & - *btg+18.*a1*a1*a2x*(b2-3.*a2x)*btg -!------------------------------------------------------------------------------- -! forbidden turbulence area -!------------------------------------------------------------------------------- - real(kind=kind_phys),parameter :: requ=-aeqh/aeqm - real(kind=kind_phys),parameter :: epsgh=1.e-9,epsgm=requ*epsgh -!------------------------------------------------------------------------------- -! near isotropy for shear turbulence, ww/q2 lower limit -!------------------------------------------------------------------------------- - real(kind=kind_phys),parameter :: ubryl=(18.*requ*a1*a1*a2x*b2*c1*btg & - +9.*a1*a2x*a2x*b2*btg*btg) & - /(requ*adnm+adnh) - real(kind=kind_phys),parameter :: ubry=(1.+epsrs)*ubryl,ubry3=3.*ubry - real(kind=kind_phys),parameter :: aubh=27.*a1*a2x*a2x*b2*btg*btg-adnh*ubry3 - real(kind=kind_phys),parameter :: aubm=54.*a1*a1*a2x*b2*c1*btg -adnm*ubry3 - real(kind=kind_phys),parameter :: bubh=(9.*a1*a2x+3.*a2x*b2)*btg-bdnh*ubry3 - real(kind=kind_phys),parameter :: bubm=18.*a1*a1*c1 -bdnm*ubry3 - real(kind=kind_phys),parameter :: cubr=1.-ubry3,rcubr=1./cubr -!------------------------------------------------------------------------------- -! k profile constants -!------------------------------------------------------------------------------- - real(kind=kind_phys),parameter :: elcbl=0.77 -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: kts,kte - integer, intent(in ) :: lmh,lmxl,lpbl -! - real(kind=kind_phys), intent(in ) :: p608,vkarman,cp - real(kind=kind_phys), intent(in ) :: hpbl,corf,ustar,hgamu,hgamv,hgamq - real(kind=kind_phys), intent(inout) :: ct,epshol -! - real(kind=kind_phys), dimension( kts:kte ) , & - intent(in ) :: cwm, & - q, & - q2, & - t, & - the, & - u, & - v -! - real(kind=kind_phys), dimension( kts+1:kte ) , & - intent(in ) :: mf, & - ufxpbl, & - vfxpbl, & - qfxpbl -! - real(kind=kind_phys), dimension( kts:kte+1 ) , & - intent(in ) :: z -! - real(kind=kind_phys), dimension( kts+1:kte ) , & - intent(out ) :: el, & - ri, & - gh, & - s2 -! - logical,intent(in) :: pblflg -! -! local vars -! - integer :: k,lpblm - real(kind=kind_phys) :: suk,svk,elocp - real(kind=kind_phys) :: a,aden,b,bden,aubr,bubr,blmx,el0,eloq2x,ghl,s2l, & - qol2st,qol2un,qdzl,rdz,sq,srel,szq,tem,thm,vkrmz,rlambda, & - rlb,rln,f - real(kind=kind_phys) :: ckp - real(kind=kind_phys), dimension( kts:kte ) :: q1, & - en2 - real(kind=kind_phys), dimension( kts+1:kte ) :: dth, & - elm, & - rel -! -!------------------------------------------------------------------------------- -! - elocp=2.72e6/cp - ct=0. -! - do k = kts,kte - q1(k) = 0. - enddo -! - do k = kts+1,kte - dth(k) = the(k)-the(k-1) - enddo -! - do k = kts+2,kte - if(dth(k)>0..and.dth(k-1)<=0.)then - dth(k)=dth(k)+ct - exit - endif - enddo -! -! compute local gradient richardson number -! - do k = kte,kts+1,-1 - rdz=2./(z(k+1)-z(k-1)) - s2l=((u(k)-u(k-1))**2+(v(k)-v(k-1))**2)*rdz*rdz ! s**2 - if(pblflg.and.k.le.lpbl)then - suk=(u(k)-u(k-1))*rdz - svk=(v(k)-v(k-1))*rdz - s2l=(suk-hgamu/hpbl-ufxpbl(k))*suk+(svk-hgamv/hpbl-vfxpbl(k))*svk - endif - s2l=max(s2l,epsgm) - s2(k)=s2l -! - tem=(t(k)+t(k-1))*0.5 - thm=(the(k)+the(k-1))*0.5 - a=thm*p608 - b=(elocp/tem-1.-p608)*thm - ghl=(dth(k)*((q(k)+q(k-1)+cwm(k)+cwm(k-1))*(0.5*p608)+1.) & - +(q(k)-q(k-1)+cwm(k)-cwm(k-1))*a & - +(cwm(k)-cwm(k-1))*b)*rdz ! dtheta/dz - if(pblflg.and.k.le.lpbl)then - ghl=ghl-mf(k)-(hgamq/hpbl+qfxpbl(k))*a - endif - if(abs(ghl)<=epsgh)ghl=epsgh -! - en2(k)=ghl*g/thm ! n**2 - gh(k)=ghl - ri(k)=en2(k)/s2l - enddo -! -! find maximum mixing lengths and the level of the pbl top -! - do k = kte,kts+1,-1 - s2l=s2(k) - ghl=gh(k) - if(ghl>=epsgh)then - if(s2l/ghl<=requ)then - elm(k)=epsl - else - aubr=(aubm*s2l+aubh*ghl)*ghl - bubr= bubm*s2l+bubh*ghl - qol2st=(-0.5*bubr+sqrt(bubr*bubr*0.25-aubr*cubr))*rcubr - eloq2x=1./qol2st - elm(k)=max(sqrt(eloq2x*q2(k)),epsl) - endif - else - aden=(adnm*s2l+adnh*ghl)*ghl - bden= bdnm*s2l+bdnh*ghl - qol2un=-0.5*bden+sqrt(bden*bden*0.25-aden) - eloq2x=1./(qol2un+epsru) ! repsr1/qol2un - elm(k)=max(sqrt(eloq2x*q2(k)),epsl) - endif - enddo -! - do k = lpbl,lmh,-1 - q1(k)=sqrt(q2(k)) - enddo -! - szq=0. - sq =0. - do k = kte,kts+1,-1 - qdzl=(q1(k)+q1(k-1))*(z(k)-z(k-1)) - szq=(z(k)+z(k-1)-z(lmh)-z(lmh))*qdzl+szq - sq=qdzl+sq - enddo -! -! computation of asymptotic l in blackadar formula -! - el0=min(alph*szq*0.5/sq,el0max) - el0=max(el0 ,el0min) -! -! above the pbl top -! - lpblm=min(lpbl+1,kte) - do k = kte,lpblm,-1 - el(k)=(z(k+1)-z(k-1))*elfc - rel(k)=el(k)/elm(k) - enddo -! -! inside the pbl -! - epshol=min(epshol,0.0) - ckp=elcbl*((1.0-8.0*epshol)**(1./3.)) - if(lpbl>lmh)then - do k = lpbl,lmh+1,-1 - vkrmz=(z(k)-z(lmh))*vkarman - if(pblflg) then - vkrmz=ckp*(z(k)-z(lmh))*vkarman - el(k)=vkrmz/(vkrmz/el0+1.) - else - el(k)=vkrmz/(vkrmz/el0+1.) - endif - rel(k)=el(k)/elm(k) - enddo - endif -! - do k = lpbl-1,lmh+2,-1 - srel=min(((rel(k-1)+rel(k+1))*0.5+rel(k))*0.5,rel(k)) - el(k)=max(srel*elm(k),epsl) - enddo -! -! mixing length for the qnse model in stable case -! - f=max(corf,eps1) - rlambda=f/(blckdr*ustar) - do k = kte,kts+1,-1 - if(en2(k)>=0.0)then ! stable case - vkrmz=(z(k)-z(lmh))*vkarman - rlb=rlambda+1./vkrmz - rln=sqrt(2.*en2(k)/q2(k))/cn - el(k)=1./(rlb+rln) - endif - enddo -! - end subroutine mixlen -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine prodq2(lmh,dtturbl,ustar,s2,ri,q2,el,z,akm,akh, & - uxk,vxk,thxk,thvxk, & - hgamu,hgamv,hgamq,delxy, & - hpbl,pblflg,kpbl, & - mf,ufxpbl,vfxpbl,qfxpbl, & - p608, & - kts,kte) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- -! - real(kind=kind_phys),parameter :: epsq2l = 0.01,c0 = 0.55,ceps = 16.6,g = 9.81 -! - integer, intent(in ) :: kts,kte - integer, intent(in ) :: lmh,kpbl -! - real(kind=kind_phys), intent(in ) :: p608,dtturbl,ustar - real(kind=kind_phys), intent(in ) :: hgamu,hgamv,hgamq,delxy,hpbl -! - logical, intent(in ) :: pblflg -! - real(kind=kind_phys), dimension( kts:kte ) , & - intent(in ) :: uxk, & - vxk, & - thxk, & - thvxk - real(kind=kind_phys), dimension( kts+1:kte ) , & - intent(in ) :: s2, & - ri, & - akm, & - akh, & - el, & - mf, & - ufxpbl, & - vfxpbl, & - qfxpbl -! - real(kind=kind_phys), dimension( kts:kte+1 ) , & - intent(in ) :: z -! - real(kind=kind_phys), dimension( kts:kte ) , & - intent(inout) :: q2 -! -! local vars -! - integer :: k -! - real(kind=kind_phys) :: s2l,q2l,deltaz,akml,akhl,en2,pr,bpr,dis,rc02 - real(kind=kind_phys) :: suk,svk,gthvk,govrthvk,pru,prv - real(kind=kind_phys) :: thm,disel -! -!------------------------------------------------------------------------------- -! - rc02=2.0/(c0*c0) -! -! start of production/dissipation loop -! - main_integration: do k = kts+1,kte - deltaz=0.5*(z(k+1)-z(k-1)) - s2l=s2(k) - q2l=q2(k) - suk=(uxk(k)-uxk(k-1))/deltaz - svk=(vxk(k)-vxk(k-1))/deltaz - gthvk=(thvxk(k)-thvxk(k-1))/deltaz - govrthvk=g/(0.5*(thvxk(k)+thvxk(k-1))) - akml=akm(k) - akhl=akh(k) - en2=ri(k)*s2l !n**2 - thm=(thxk(k)+thxk(k-1))*0.5 -! -! turbulence production term -! - if(pblflg.and.k.le.kpbl)then - pru=(akml*(suk-hgamu/hpbl-ufxpbl(k)))*suk - prv=(akml*(svk-hgamv/hpbl-vfxpbl(k)))*svk - else - pru=akml*suk*suk - prv=akml*svk*svk - endif - pr=pru+prv -! -! buoyancy production -! - if(pblflg.and.k.le.kpbl)then - bpr=(akhl*(gthvk-mf(k)-(hgamq/hpbl+qfxpbl(k))*p608*thm))*govrthvk - else - bpr=akhl*gthvk*govrthvk - endif -! -! dissipation -! - disel=min(delxy,ceps*el(k)) - dis=(q2l)**1.5/disel -! - q2l=q2l+2.0*(pr-bpr-dis)*dtturbl - q2(k)=amax1(q2l,epsq2l) -! -! end of production/dissipation loop -! - enddo main_integration -! -! lower boundary condition for q2 -! - q2(kts)=amax1(rc02*ustar*ustar,epsq2l) -! - end subroutine prodq2 -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine vdifq(lmh,dtdif,q2,el,z, & - akhk,ptke1, & - hgame,hpbl,pblflg,kpbl, & - efxpbl, & - kts,kte) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- -! - real(kind=kind_phys),parameter :: c_k=1.0,esq=5.0 -! - integer, intent(in ) :: kts,kte - integer, intent(in ) :: lmh,kpbl -! - real(kind=kind_phys), intent(in ) :: dtdif,hpbl,efxpbl -! - logical, intent(in ) :: pblflg -! - real(kind=kind_phys), dimension( kts:kte ) , & - intent(in ) :: hgame, & - ptke1 - real(kind=kind_phys), dimension( kts+1:kte ) , & - intent(in ) :: el, & - akhk - real(kind=kind_phys), dimension( kts:kte+1 ) , & - intent(in ) :: z -! - real(kind=kind_phys), dimension( kts:kte ) , & - intent(inout) :: q2 -! -! local vars -! - integer :: k -! - real(kind=kind_phys) :: aden,akqs,bden,besh,besm,cden,cf,dtozs,ell,eloq2,eloq4 - real(kind=kind_phys) :: elqdz,esh,esm,esqhf,ghl,gml,q1l,rden,rdz - real(kind=kind_phys) :: zak -! - real(kind=kind_phys), dimension( kts+1:kte ) :: zfacentk - real(kind=kind_phys), dimension( kts+2:kte ) :: akq, & - cm, & - cr, & - dtoz, & - rsq2 -! -!------------------------------------------------------------------------------- -! -! vertical turbulent diffusion -! - esqhf=0.5*esq - do k = kts+1,kte - zak=0.5*(z(k)+z(k-1)) !zak of vdifq = za(k-1) of shinhong2d - zfacentk(k)=(zak/hpbl)**3.0 - enddo -! - do k = kte,kts+2,-1 - dtoz(k)=(dtdif+dtdif)/(z(k+1)-z(k-1)) - akq(k)=c_k*(akhk(k)/(z(k+1)-z(k-1))+akhk(k-1)/(z(k)-z(k-2))) - akq(k)=akq(k)*ptke1(k) - cr(k)=-dtoz(k)*akq(k) - enddo -! - akqs=c_k*akhk(kts+1)/(z(kts+2)-z(kts)) - akqs=akqs*ptke1(kts+1) - cm(kte)=dtoz(kte)*akq(kte)+1. - rsq2(kte)=q2(kte) -! - do k = kte-1,kts+2,-1 - cf=-dtoz(k)*akq(k+1)/cm(k+1) - cm(k)=-cr(k+1)*cf+(akq(k+1)+akq(k))*dtoz(k)+1. - rsq2(k)=-rsq2(k+1)*cf+q2(k) - if(pblflg.and.k.lt.kpbl) then - rsq2(k)=rsq2(k)-dtoz(k)*(2.0*hgame(k)/hpbl)*akq(k+1)*(z(k+1)-z(k)) & - +dtoz(k)*(2.0*hgame(k-1)/hpbl)*akq(k)*(z(k)-z(k-1)) - rsq2(k)=rsq2(k)-dtoz(k)*2.0*efxpbl*zfacentk(k+1) & - +dtoz(k)*2.0*efxpbl*zfacentk(k) - endif - enddo -! - dtozs=(dtdif+dtdif)/(z(kts+2)-z(kts)) - cf=-dtozs*akq(lmh+2)/cm(lmh+2) -! - if(pblflg.and.((lmh+1).lt.kpbl)) then - q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1) & - -dtozs*(2.0*hgame(lmh+1)/hpbl)*akq(lmh+2)*(z(lmh+2)-z(lmh+1)) & - +dtozs*(2.0*hgame(lmh)/hpbl)*akqs*(z(lmh+1)-z(lmh))) - q2(lmh+1)=q2(lmh+1)-dtozs*2.0*efxpbl*zfacentk(lmh+2) & - +dtozs*2.0*efxpbl*zfacentk(lmh+1) - q2(lmh+1)=q2(lmh+1)/((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) - else - q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1)) & - /((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) - endif -! - do k = lmh+2,kte - q2(k)=(-cr(k)*q2(k-1)+rsq2(k))/cm(k) - enddo -! - end subroutine vdifq -!------------------------------------------------------------------------------- - function pu(d,h) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- - real(kind=kind_phys) :: pu - real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 - real(kind=kind_phys),parameter :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071 - real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 - real(kind=kind_phys) :: d,h,doh,num,den -! - doh=d/h - num=a1*(doh)**b1+a2*(doh)**b2 - den=a3*(doh)**b1+a4*(doh)**b2+a5 - pu=num/den - pu=max(pu,pmin) - pu=min(pu,pmax) -! - return - end function -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - function pq(d,h) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- - real(kind=kind_phys) :: pq - real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 - real(kind=kind_phys),parameter :: a1 = 1.0, a2 = -0.098, a3 = 1.0, a4 = 0.106, a5 = 0.5 - real(kind=kind_phys),parameter :: b1 = 2.0 - real(kind=kind_phys) :: d,h,doh,num,den -! - doh=d/h - num=a1*(doh)**b1+a2 - den=a3*(doh)**b1+a4 - pq=a5*num/den+(1.-a5) - pq=max(pq,pmin) - pq=min(pq,pmax) -! - return - end function -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - function pthnl(d,h) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- - real(kind=kind_phys) :: pthnl - real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 - real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.936, a3 = -1.110, & - a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243 - real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.875 - real(kind=kind_phys) :: d,h,doh,num,den -! - doh=d/h - num=a1*(doh)**b1+a2*(doh)**b2+a3 - den=a4*(doh)**b1+a5*(doh)**b2+a6 - pthnl=a7*num/den+(1.-a7) - pthnl=max(pthnl,pmin) - pthnl=min(pthnl,pmax) -! - return - end function -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - function pthl(d,h) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- - real(kind=kind_phys) :: pthl - real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 - real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.870, a3 = -0.913, & - a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280 - real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.5 - real(kind=kind_phys) :: d,h,doh,num,den -! - doh=d/h - num=a1*(doh)**b1+a2*(doh)**b2+a3 - den=a4*(doh)**b1+a5*(doh)**b2+a6 - pthl=a7*num/den+(1.-a7) - pthl=max(pthl,pmin) - pthl=min(pthl,pmax) -! - return - end function -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - function ptke(d,h) -!------------------------------------------------------------------------------- - use machine , only : kind_phys - implicit none -!------------------------------------------------------------------------------- - real(kind=kind_phys) :: ptke - real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 - real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.070, & - a3 = 1.000, a4 = 0.142, a5 = 0.071 - real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 - real(kind=kind_phys) :: d,h,doh,num,den -! - doh=d/h - num=a1*(doh)**b1+a2*(doh)**b2 - den=a3*(doh)**b1+a4*(doh)**b2+a5 - ptke=num/den - ptke=max(ptke,pmin) - ptke=min(ptke,pmax) -! - return - end function -!------------------------------------------------------------------------------- - end module shinhongvdif diff --git a/physics/ysuvdif.F90 b/physics/ysuvdif.F90 deleted file mode 100644 index e76f2120b..000000000 --- a/physics/ysuvdif.F90 +++ /dev/null @@ -1,1271 +0,0 @@ -!> \file ysuvdif.F90 -!! This file contains the CCPP-compliant YSU scheme which computes -!! subgrid vertical turbulence mixing using traditional K-profile method -!! Please refer to (Hong, Noh and Dudhia, 2006, MWR). -!! -!! Subroutine 'ysuvdif_run' computes subgrid vertical turbulence mixing -!! using YSU K-profile method -!! -!---------------------------------------------------------------------- - - module ysuvdif - contains - - subroutine ysuvdif_init () - end subroutine ysuvdif_init - - subroutine ysuvdif_finalize () - end subroutine ysuvdif_finalize - -!> \defgroup YSU FV3GFS ysuvdif_run Main -!! \brief This subroutine contains all of the logic for the -!! YSU scheme. -!! -!> \section arg_table_ysuvdif_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | -!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | -!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | -!! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | -!! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | -!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | -!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | -!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | -!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | -!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | -!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | -!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | -!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | -!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | -!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | -!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | -!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | -!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | -!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | -!! -!------------------------------------------------------------------------------- - subroutine ysuvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & - utnp,vtnp,ttnp,qtnp, & - swh,hlw,xmu,ntrac,ndiff,ntcw,ntiw, & - phii,phil,psfcpa, & - zorl,stress,hpbl,psim,psih, & - landmask,heat,evap,wspd,br, & - g,rd,cp,rv,ep1,ep2,xlv, & - dusfc,dvsfc,dtsfc,dqsfc, & - dt,kpbl1d,u10,v10,errmsg,errflg ) - - use machine , only : kind_phys -! -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- - 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 - real(kind=kind_phys),parameter :: rcl = 1.0 - real(kind=kind_phys),parameter :: karman = 0.4 - integer,parameter :: imvdif = 1 - integer,parameter :: ysu_topdown_pblmix = 1 -! -!------------------------------------------------------------------------------------- -! input variables - integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw - real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt - - real(kind=kind_phys), dimension( ix,km ), & - intent(in) :: pi2d,p2d,phil,ux,vx,swh,hlw,tx - - real(kind=kind_phys), dimension( ix,km,ntrac ) , & - intent(in ) :: qx - - real(kind=kind_phys), dimension( ix, km+1 ) , & - intent(in ) :: p2di,phii - - real(kind=kind_phys), dimension( im ) , & - intent(in) :: stress,zorl,heat,evap,wspd,br,psim,psih,psfcpa, & - u10,v10,xmu - integer, dimension(im) ,& - intent(in ) :: landmask -! -!---------------------------------------------------------------------------------- -! input/output variables -! - real(kind=kind_phys), dimension( im,km ) , & - intent(inout) :: utnp,vtnp,ttnp - real(kind=kind_phys), dimension( im,km,ntrac ) , & - intent(inout) :: qtnp -! -!--------------------------------------------------------------------------------- -! output variables - integer, dimension( im ), intent(out ) :: kpbl1d - real(kind=kind_phys), dimension( im ), & - intent(out) :: hpbl - - ! error messages - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -!-------------------------------------------------------------------------------- -! -! local vars -! - real(kind=kind_phys), dimension( im ) :: hol - real(kind=kind_phys), dimension( im, km+1 ) :: zq -! - real(kind=kind_phys), dimension( im, km ) :: & - thx,thvx,thlix, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za -! - real(kind=kind_phys), dimension( im ) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - prpbl, & - wspd1,thermalli -! - real(kind=kind_phys), dimension( im, km ) :: xkzm,xkzh, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - xkzq, & - zfac, & - rhox2, & - hgamt2 -! - real(kind=kind_phys), dimension( im ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real(kind=kind_phys), dimension( im ) :: xland - real(kind=kind_phys), dimension( im ) :: ust - real(kind=kind_phys), dimension( im ) :: hfx - real(kind=kind_phys), dimension( im ) :: qfx - real(kind=kind_phys), dimension( im ) :: znt - real(kind=kind_phys), dimension( im ) :: uox - real(kind=kind_phys), dimension( im ) :: vox -! - real(kind=kind_phys), dimension( im, km, ndiff) :: r3,f3 - integer, dimension( im ) :: kpbl,kpblold -! - logical, dimension( im ) :: pblflg, & - sfcflg, & - stable, & - cloudflg - - logical :: definebrup -! - integer :: n,i,k,l,ic,is,kk - integer :: klpbl, ktrace1, ktrace2, ktrace3 -! -! - 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, rovcp -! - - real(kind=kind_phys), dimension( im, km ) :: wscalek,wscalek2 - real(kind=kind_phys), dimension( im ) :: wstar - real(kind=kind_phys), dimension( im ) :: delta - real(kind=kind_phys), dimension( im, km ) :: xkzml,xkzhl, & - zfacent,entfac - real(kind=kind_phys), dimension( im ) :: 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 -! -!------------------------------------------------------------------------------- -! -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - klpbl = km -! - rovcp=rd/cp - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! -! change xland values - do i=1,im - if(landmask(i).eq.0) then !ocean - xland(i) = 2 - else - xland(i) = 1 !land - end if - end do -! - do k = 1,km - do i = 1,im - thx(i,k) = tx(i,k)/pi2d(i,k) - thlix(i,k) = (tx(i,k)-xlv*qx(i,k,ntcw)/cp-2.834E6*qx(i,k,ntiw)/cp)/pi2d(i,k) - enddo - enddo -! - do k = 1,km - do i = 1,im - tvcon = (1.+ep1*qx(i,k,1)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - do i = 1,im - tvcon = (1.+ep1*qx(i,1,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF - qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF - ust(i) = sqrt(stress(i)) ! reset to the variable in WRF - znt(i) = 0.01*zorl(i) ! reset to the variable in WRF - uox(i) = 0.0 - vox(i) = 0.0 - enddo -! -!-----compute the height of full- and half-sigma levels above ground -! level, and the layer thicknesses. -! - do i = 1,im - zq(i,1) = 0. - enddo -! - do k = 1,km - do i = 1,im - zq(i,k+1) = phii(i,k+1)*conw - tvcon = (1.+ep1*qx(i,k,1)) - rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) - enddo - enddo -! - do k = 1,km - do i = 1,im - za(i,k) = phil(i,k)*conw - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - enddo - enddo -! - do i = 1,im - dza(i,1) = za(i,1) - enddo -! - do k = 2,km - do i = 1,im - dza(i,k) = za(i,k)-za(i,k-1) - enddo - enddo - -! write(0,*)"===CALLING ysu; input:" -! print*,"t:",tx(1,1),tx(1,2),tx(1,km) -! print*,"u:",ux(1,1),ux(1,2),ux(1,km) -! print*,"v:",vx(1,1),vx(1,2),vx(1,km) -! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) -! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) -! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) -! print*,"phil:",za(1,1),za(1,2),za(1,km) -! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) -! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) -! print *,"del:",del(1,1),del(1,2),del(1,km) -! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) -! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) -! print*,"rd,rv,g:",rd,rv,g -! print*,"ep1,ep2,xlv:",ep1,ep2,xlv -! print*,"br,psim,psih:",br(1),psim(1),psih(1) -! print*,"u10,v10:",u10(1),v10(1) -! print*,"psfcpa,cp:",psfcpa(1),cp -! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw -! -! -!-----initialize vertical tendencies and -! -! utnp(:,:) = 0. -! vtnp(:,:) = 0. -! ttnp(:,:) = 0. -! qtnp(:,:,:) = 0. -! - do i = 1,im - 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 = 1,im - 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 = 1,klpbl - do i = 1,im - wscalek(i,k) = 0.0 - wscalek2(i,k) = 0.0 - enddo - enddo -! - do k = 1,klpbl - do i = 1,im - zfac(i,k) = 0.0 - enddo - enddo - do k = 1,klpbl-1 - do i = 1,im - xkzom(i,k) = xkzminm - xkzoh(i,k) = xkzminh - enddo - enddo -! - do i = 1,im - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do i = 1,im - 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 = 1,im - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - enddo -! - do k = 2,klpbl - do i = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - if(pblflg(i))then - kpbl(i) = 1 - hpbl(i) = zq(i,1) - endif - enddo -! - do i = 1,im - if(pblflg(i))then - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - endif - enddo -! - do k = 2,klpbl - do i = 1,im - 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 = 1,im - kpblold(i) = kpbl(i) - definebrup=.false. - do k = kpblold(i), km-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 = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - 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 = 1,im - 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,k,ntcw)+qx(i,k,ntiw)).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,1)+qx(i,k,ntcw))-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,1)+qx(i,k,ntcw))-rvls,0.) - !entrainment efficiency - dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2,1)+qx(i,k+2,ntcw))) & - - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k,1) +qx(i,k,ntcw))) - 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=swh(i,kk)*xmu(i)+hlw(i,kk) !radiative heating rate 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(qx(i,k+1,1)-qx(i,k,1),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 = 1,klpbl - do i = 1,im - 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 = 1,klpbl - do i = 1,im - 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 = 1,km-1 - do i = 1,im - 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.ntcw.ge.2.and.ntiw.ge.2)then - if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.(qx(i & - ,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3)then -! in cloud - qmean = 0.5*(qx(i,k,1)+qx(i,k+1,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 = 1,km - do i = 1,im - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - enddo - enddo -! - do i = 1,im - ad(i,1) = 1. - f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = 1,km-1 - do i = 1,im - dtodsd = dt2/del(i,k) - dtodsu = 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 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = 1,km - do i = 1,im - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - enddo - enddo -! - call tridin_ysu(al,ad,cu,r1,au,f1,im,km,1) -! -! recover tendencies of heat -! - do k = km,1,-1 - do i = 1,im - 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) - enddo - enddo -! -! compute tridiagonal matrix elements for moisture, clouds, and gases -! - do k = 1,km - do i = 1,im - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - enddo - enddo -! - do ic = 1,ndiff - do i = 1,im - do k = 1,km - f3(i,k,ic) = 0. - enddo - enddo - enddo -! - do i = 1,im - ad(i,1) = 1. - f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - do i = 1,im - f3(i,1,ic) = qx(i,1,ic) - enddo - enddo - endif -! - do k = 1,km-1 - do i = 1,im - if(k.ge.kpbl(i)) then - xkzq(i,k) = xkzh(i,k) - endif - enddo - enddo -! - do k = 1,km-1 - do i = 1,im - dtodsd = dt2/del(i,k) - dtodsu = 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,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,1) - else - f3(i,k+1,1) = qx(i,k+1,1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - do k = 1,km-1 - do i = 1,im - f3(i,k+1,ic) = qx(i,k+1,ic) - enddo - enddo - enddo - endif -! -! copies here to avoid duplicate input args for tridin -! - do k = 1,km - do i = 1,im - cu(i,k) = au(i,k) - enddo - enddo -! - do ic = 1,ndiff - do k = 1,km - do i = 1,im - 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,im,km,ndiff) -! -! recover tendencies of heat and moisture -! - do k = km,1,-1 - do i = 1,im - qtend = (f3(i,k,1)-qx(i,k,1))*rdt - qtnp(i,k,1) = qtnp(i,k,1)+qtend - dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - do k = km,1,-1 - do i = 1,im - qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt - qtnp(i,k,ic) = qtnp(i,k,ic)+qtend - enddo - enddo - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i = 1,im - do k = 1,km - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - f2(i,k) = 0. - enddo - enddo -! - do i = 1,im - ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) - enddo -! - do k = 1,km-1 - do i = 1,im - dtodsd = dt2/del(i,k) - dtodsu = 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 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = 1,km - do i = 1,im - 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 tridi1n(al,ad,cu,r1,r2,au,f1,f2,im,km,1) -! -! recover tendencies of momentum -! - do k = km,1,-1 - do i = 1,im - 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 -! -!---- end of vertical diffusion -! - do i = 1,im - kpbl1d(i) = kpbl(i) - enddo -! -! - end subroutine ysuvdif_run -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,im,km,nt) - use machine , only : kind_phys -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: im, km, nt -! - real(kind=kind_phys), dimension( im, 2:km+1 ) , & - intent(in ) :: cl -! - real(kind=kind_phys), dimension( im, km ) , & - intent(in ) :: cm, & - r1 - real(kind=kind_phys), dimension( im, km,nt ) , & - intent(in ) :: r2 -! - real(kind=kind_phys), dimension( im, km ) , & - intent(inout) :: au, & - cu, & - f1 - real(kind=kind_phys), dimension( im, km,nt ) , & - intent(inout) :: f2 -! - real(kind=kind_phys) :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = im - n = km -! - do i = 1,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 = 1,l - fk = 1./cm(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do k = 2,n-1 - do i = 1,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 = 2,n-1 - do i = 1,l - fk = 1./(cm(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 = 1,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 = 1,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 k = n-1,1,-1 - do i = 1,l - f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) - enddo - enddo -! - do it = 1,nt - do k = n-1,1,-1 - do i = 1,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridi1n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,im,km,nt) - use machine , only : kind_phys -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: im, km, nt -! - real(kind=kind_phys), dimension( im, 2:km+1 ) , & - intent(in ) :: cl -! - real(kind=kind_phys), dimension( im, km ) , & - intent(in ) :: cm - real(kind=kind_phys), dimension( im, km,nt ) , & - intent(in ) :: r2 -! - real(kind=kind_phys), dimension( im, km ) , & - intent(inout) :: au, & - cu - real(kind=kind_phys), dimension( im, km,nt ) , & - intent(inout) :: f2 -! - real(kind=kind_phys) :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = im - n = km -! - do it = 1,nt - do i = 1,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 = 2,n-1 - do i = 1,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 = 1,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,1,-1 - do i = 1,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridin_ysu -!------------------------------------------------------------------------------- -end module ysuvdif -!------------------------------------------------------------------------------- From 4086ec97e7feae9a83fb29d122e6bde504a45d37 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Fri, 7 Jun 2019 13:49:50 -0600 Subject: [PATCH 04/19] scidoc update --- physics/GFS_MP_generic.F90 | 2 +- physics/cnvc90.f | 2 +- physics/cs_conv.F90 | 67 +++++------ physics/cs_conv_aw_adj.F90 | 2 +- physics/docs/library.bib | 12 +- physics/docs/pdftxt/CPT_CSAW.txt | 11 +- physics/docs/pdftxt/CPT_adv_suite.txt | 24 ++-- physics/docs/pdftxt/GFSv15_suite.txt | 111 +++++++++--------- physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt | 113 +++++++++---------- physics/docs/pdftxt/GSD_THOMPSON.txt | 4 +- physics/docs/pdftxt/GSD_adv_suite.txt | 16 +-- physics/gfdl_fv_sat_adj.F90 | 2 +- physics/gwdc.f | 3 +- physics/gwdps.f | 2 +- physics/h2ophys.f | 2 +- physics/m_micro.F90 | 21 ++-- physics/module_bl_mynn.F90 | 82 ++++++++------ physics/module_mp_thompson.F90 | 75 ++++++------ physics/module_sf_ruclsm.F90 | 8 +- physics/moninedmf.f | 2 +- physics/mp_thompson.F90 | 9 +- physics/ozphys_2015.f | 2 +- physics/radiation_aerosols.f | 14 --- physics/radlw_main.f | 2 +- physics/radsw_main.f | 2 +- physics/rayleigh_damp.f | 2 +- physics/samfdeepcnv.f | 2 +- physics/samfshalcnv.f | 2 +- physics/satmedmfvdif.F | 2 +- physics/sfc_diff.f | 2 +- physics/sfc_drv_ruc.F90 | 3 +- physics/sfc_nst.f | 2 +- physics/sfc_sice.f | 2 +- 33 files changed, 294 insertions(+), 313 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 0aeada850..ea3466261 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -84,7 +84,7 @@ module GFS_MP_generic_post subroutine GFS_MP_generic_post_init end subroutine GFS_MP_generic_post_init -!>\defgroup gfs_calpreciptype GFS/GFDL calpreciptype Main +!>\defgroup gfs_calpreciptype GFS Precipitation Type Diagnostics Module !! \brief If dominant precip type is requested (i.e., Zhao-Carr MP scheme), 4 more algorithms in calpreciptype() !! will be called. the tallies are then summed in calwxt_dominant(). For GFDL cloud MP scheme, determine convective !! rain/snow by surface temperature; and determine explicit rain/snow by rain/snow coming out directly from MP. diff --git a/physics/cnvc90.f b/physics/cnvc90.f index 08dbbbc9d..800ccb5dc 100644 --- a/physics/cnvc90.f +++ b/physics/cnvc90.f @@ -12,7 +12,7 @@ module cnvc90 subroutine cnvc90_init() end subroutine cnvc90_init -!>\defgroup GFS_cnvc90 GFS cnvc90 Main +!>\defgroup GFS_cnvc90 GFS Convective Cloud Diagnostics Module !> @{ !! This module contains the calculation of fraction of convective cloud, !! pressure at bottom of convective cloud and at top of convective diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index d5c2e1011..cb0c0b98b 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -256,7 +256,7 @@ end subroutine cs_conv_init subroutine cs_conv_finalize() end subroutine cs_conv_finalize -!>\defgroup cs_scheme CPT Chikira-Sugiyama Cumulus Scheme Module +!>\defgroup cs_scheme Chikira-Sugiyama Cumulus Scheme Module !> \brief The subroutine contains the main driver for Chikira-Sugiyama convective scheme. !! !! \author Minoru Chikira @@ -531,13 +531,15 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & enddo !DD following adapted from ras -!> -# Following RAS, separate total condensate to ice/water separately -!! - The ratio of ice cloud to cloud water is determined by a linear function +!> -# Following the Relaxed Arakawa Schubert Scheme (RAS; +!! Moorthi and Suarez 1992 \cite moorthi_and_suarez_1992 ), +!! separate total condensate between ice and water. +!! The ratio of cloud ice to cloud water is determined by a linear function !! of temperature: !!\f[ !! F_i(T)= (T_2-T)/(T_2-T_1) !!\f] -!! where T is temperature; \f$T_1\f$ and \f$T_2\f$ are set as tcf=263.16 +!! where T is temperature, and\f$T_1\f$ and \f$T_2\f$ are set as tcf=263.16 !! and tf= 233.16 if (clw(1,1,2) <= -999.0) then ! input ice/water are together do k=1,kmax @@ -572,7 +574,7 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & ! !*************************************************************************************** ! -!> -# Calculate temperature at interfaces. +!> -# Calculate temperature at interfaces ! DO K=2,KMAX @@ -589,7 +591,7 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & GDTM(I,1) = GDT(I,1) ! Is this a good approximation ? - Moorthi ENDDO -!> -# Initialize the sigma diagnostics. +!> -# Initialize the sigma diagnostics do n=1,nctp do k=1,kmax do i=ists,iens @@ -603,7 +605,7 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & enddo enddo ! -!> -# Call cs_cumlus() for CS cumulus parameterization. +!> -# Call cs_cumlus() for the main CS cumulus parameterization call CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions otspt(1:ntr,1), otspt(1:ntr,2), & lprnt , ipr , & @@ -736,7 +738,7 @@ subroutine cs_conv_run(IM , IJSDIM , KMAX , ntracp1 , NN, & endif enddo -!> -# Multiplying mass fluxes by the time step +!> -# Multiply mass fluxes by the time step do k=1,kmax do i=1,ijsdim @@ -768,7 +770,7 @@ end subroutine cs_conv_run !************************************************************************ !>\ingroup cs_scheme -!! This subroutine includes cumulus parameterization with +!! Main subroutine for the cumulus parameterization with !! state-dependent entrainment rate developed by Minoru Chikira. !! !! - This routine works as the prognostic Arakawa-Schubert scheme @@ -777,7 +779,7 @@ end subroutine cs_conv_run !! - Specify OPT_CUMBGT to check water and energy budget. !! - Specify OPT_CUMCHK to check range of output values. !! -!! History: +!! History(yy/mm/dd): !! - 08/09/19(chikira) MIROC4.1 !! - 08/10/30(hiro) CMT modified !! - 08/11/11(chikira) Neggers et al. (2002) @@ -1102,8 +1104,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo !> -# Compute layer saturate moisture \f$Q_i\f$(GDQS) and -!! saturate moist static energy GDHS (see appendix B in -!! Chirika and Sugiyama (2010) \cite Chikira_2010) +!! saturate moist static energy (GDHS; see Appendix B in +!! Chikira and Sugiyama (2010) \cite Chikira_2010) DO K=1,KMAX DO I=ISTS,IENS esat = min(gdp(i,k), fpvs(gdt(i,k))) @@ -1137,7 +1139,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !DDsigma - arguments added to get subcloud profiles in updraft ! so AW eddy flux tendencies can be computed -!> -# Call cumbas() to compute cloud base properties. +!> -# Call cumbas() to compute cloud base properties CALL CUMBAS(IJSDIM, KMAX , & !DD dimensions KB , GCYM(1,1,1) , KBMX , & ! output ntr , ntrq , & @@ -1150,7 +1152,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ISTS , IENS , & !) ! input gctbl, gcqbl,gdq,gcwbl, gcqlbl, gcqibl, gctrbl) ! sub cloud tendencies ! -!> -# Compute CAPE and CIN. +!> -# Compute CAPE and CIN ! DO I=ISTS,IENS CAPE(i) = zero @@ -1181,7 +1183,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO !DDsigma some initialization before summing over cloud type -!> -# Initialization before summing over cloud type +!> -# Initialize variables before summing over cloud types do k=1,kmax ! Moorthi do i=1,ijsdim lamdaprod(i,k) = one @@ -1221,7 +1223,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! before and after CUMUP (i.e. here), and inside the routine, in ! particular: gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim,gctrm ! also, inside, check that no reads/writes out of bounds occur *DH -!> -# Call cumup() to compute in-cloud properties. +!> -# Call cumup() to compute in-cloud properties CALL CUMUP(IJSDIM, KMAX, NTR, ntrq, & !DD dimensions ACWF , & ! output GCLZ , GCIZ , GPRCIZ , GSNWIZ, & ! output @@ -1242,7 +1244,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions gctm , gcqm, gcwm, gchm, gcwt, gclm, gcim, gctrm, & ! additional incloud profiles and cloud top total water lprnt , ipr ) ! -!> -# Call cumbmx() to compute cloud base mass flux. +!> -# Call cumbmx() to compute cloud base mass flux CALL CUMBMX(IJSDIM, KMAX, & !DD dimensions CBMFX(1,CTP), & ! modified ACWF , GCYT(1,CTP), GDZM , & ! input @@ -1255,7 +1257,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions do i=ISTS,IENS if (flx_form) then -!> -# Initialize eddy fluxes for cloud type ctp +!> -# Initialize eddy fluxes for cloud types do k=1,kmax+1 sfluxtem(k) = zero qvfluxtem(k) = zero @@ -1278,7 +1280,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions km1 = k - 1 rhs_h = zero rhs_q = zero -!> -# Get environment variables interpolated to layer interface +!> -# Interpolate environment variables to layer interface GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) ! as computed in cumup ! GDwM = half * (GDw(I,K) + GDw(I,KM1 )) GDlM = half * (GDQ(I,K,3) + GDQ(I,KM1,3)) @@ -1290,9 +1292,9 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions if (do_aw) then -!> -# Compute lamda for a cloud type (eqn 23 of Arakawa and Wu (2013)), -!! and then updraft area fraction -!! (sigmai, eqn 12 of Arakawa and We (2013)) +!> -# Compute lamda for a cloud type and then updraft area fraction +!! (sigmai) following Equations 23 and 12 of +!! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 , respectively lamdai = mflx_e * rair * gdtm(i,k)*(one+epsvt*gdqm) & / (gdpm(i,k)*wcv(i,k)) @@ -1314,7 +1316,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! fsigma = 1.0 ! no aw effect, comment following lines to undo AW fsigma = one - sigma(i,k) -!> -# Compute tendencies based on mass flux, and tendencies based on condensation +!> -# Compute tendencies based on mass flux and condensation ! fsigma is the AW reduction of flux tendencies if(k == kbi) then @@ -1424,8 +1426,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! rhs_q = cbmfl*((gcwt(i)-gcqt(i,ctp)) - (gcym(i,k-1)*(gcwm(i,k-1)-gcqm(i,k-1)) + (GDw( I,K-1 )-gdq(i,k-1,1))*(gcyt(i,ctp)-gcym(i,k-1))) ) ! endif -!> -# Compute condesation, total precip production, frozen precip production, -!! heating due to freezing and total temperature tendency due to in cloud microphysics +!> -# Compute condensation, total precipitation production, frozen precipitation production, +!! heating due to freezing, and total temperature tendency due to in-cloud microphysics dqcondtem(i,km1) = -rhs_q ! condensation ! dqprectem(i,km1) = cbmfl * (GPRCIZ(i,k) + GSNWIZ(i,k)) dqprectem(i,km1) = tem * (GPRCIZ(i,k) + GSNWIZ(i,k)) ! total precip production @@ -1453,7 +1455,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) * delpinv frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) * delpinv -!> -# Compute flux tendencies - compute the vertical flux divergence +!> -# Compute flux tendencies and vertical flux divergence sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv @@ -1501,7 +1503,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo ! -!> -# Call cumflx() to compute Cloud Mass Flux & Precip. +!> -# Call cumflx() to compute cloud mass flux and precipitation CALL CUMFLX(IM , IJSDIM, KMAX , & !DD dimensions GMFX0 , GPRCI , GSNWI , CMDET, & ! output QLIQ , QICE , GTPRC0, & ! output @@ -1561,7 +1563,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo -!> -# Call cumdwn() to compute cumulus downdraft - Melt & Freeze & Evaporation. +!> -# Call cumdwn() to compute cumulus downdraft and assocated melt, freeze +!! and evaporation CALL CUMDWN(IM , IJSDIM, KMAX , NTR , ntrq , & ! DD dimensions GTT , GTQ , GTU , GTV , & ! modified GMFLX , & ! modified updraft+downdraft flux @@ -1585,7 +1588,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! enddo ! enddo -!> -# Call cumsbw() to compute cloud subsidence heating. +!> -# Call cumsbw() to compute cloud subsidence heating if (.not. flx_form) then ! Cloud Subsidence Heating ! -----------------------= @@ -1655,7 +1658,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO ! if(do_aw .and. flx_form) then ! compute AW tendencies -!> -# Compute AW tendencies of T/ql/qi +!> -# Compute AW tendencies of T, ql and qi if(flx_form) then ! compute AW tendencies ! AW lump all heating together, compute qv term do k=1,kmax @@ -1733,7 +1736,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! enddo ! enddo ! -!> -# Call cumfxr() for tracer mass fixer without detrainment. +!> -# Call cumfxr() for tracer mass fixer without detrainment CALL CUMFXR(IM , IJSDIM, KMAX , NTR , & !DD dimensions GTQ , & ! modified GDQ , DELP , DELTA , KTMXT , IMFXR, & ! input @@ -3932,7 +3935,7 @@ SUBROUTINE CUMSBR & !! Tracer Subsidence END SUBROUTINE CUMSBR !********************************************************************* !>\ingroup cs_scheme -!! This subroutine calculates tracer mass fixer without deterainment +!! This subroutine calculates tracer mass fixer without detrainment. SUBROUTINE CUMFXR & ! Tracer mass fixer ( IM , IJSDIM, KMAX , NTR , & !DD dimensions GTR , & ! modified diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 index 08d3f4516..871fbe213 100644 --- a/physics/cs_conv_aw_adj.F90 +++ b/physics/cs_conv_aw_adj.F90 @@ -1,7 +1,7 @@ !> \file cs_conv_aw_adj.F90 !! This file contains a subroutine to adjusts surface rainrate for conservation for CSAW. -!>\defgroup mod_cs_conv_aw_adj CPT cs_conv_aw_adj Module +!>\defgroup mod_cs_conv_aw_adj CSAW adjustment Module !! This module adjusts surface rainrate for conservation. !> @{ module cs_conv_aw_adj diff --git a/physics/docs/library.bib b/physics/docs/library.bib index dbc820d07..96f57cef5 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,13 +1,23 @@ %% This BibTeX bibliography file was created using BibDesk. %% http://bibdesk.sourceforge.net/ -%% Created for Man Zhang at 2019-06-05 10:35:17 -0600 +%% Created for Man Zhang at 2019-06-06 11:56:03 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{moorthi_and_suarez_1992, + Author = {S. Moorthi and M.J. Suarez }, + Date-Added = {2019-06-06 17:51:50 +0000}, + Date-Modified = {2019-06-06 17:56:00 +0000}, + Journal = {Monthly Weather Review}, + Pages = {978-1002}, + Title = {Relaxed Arakawa-Schubert. A parameterization of moist convection for general circulation models}, + Volume = {120}, + Year = {1992}} + @article{Gettelman_et_al_2019, Author = {A. Gettelman and H. Morrison and K. Thayer-Calder and C. M. Zarzycki}, Date-Added = {2019-06-05 16:32:22 +0000}, diff --git a/physics/docs/pdftxt/CPT_CSAW.txt b/physics/docs/pdftxt/CPT_CSAW.txt index 781c9937a..b7e178f82 100644 --- a/physics/docs/pdftxt/CPT_CSAW.txt +++ b/physics/docs/pdftxt/CPT_CSAW.txt @@ -2,12 +2,13 @@ \page CSAW_scheme Scale-Aware Chikira-Sugiyama Scale-aware Convection Scheme with Arakawa-Wu Extension \section cs_descrip Description -Chikira-Sugiyama cumulus scheme (Chikira and Sugiyama (2010) \cite Chikira_2010) with prognostic closure and +The Chikira-Sugiyama cumulus scheme (Chikira and Sugiyama (2010) \cite Chikira_2010) with prognostic closure and Arakawa-Wu Scale-Aware extension \cite Arakawa_2013 is an offshoot of the prognostic Arakawa-Schubert scheme. -It is characterized by lateral entrainment rates that vertically varies depending on buoyancy and vertical -velocity of updraft air parcel following Gregory (2001) \cite Gregory_2001 and spectral representation of -cloud types according to updraft velocity at cloud base. Cloud base mass flux is determined by convective -kinetic energy closure. The entrainment rate tends to be large near cloud base because of the small updraft +It is characterized by a spectral representation of cloud types according to updraft velocity at cloud base, a level +at which the mass flux is determined by a convective kinetic energy closure. The +lateral entrainment rate vertically varies depending on the buoyancy and vertical +velocity of the updraft air parcel following Gregory (2001) \cite Gregory_2001 . + The entrainment rate tends to be large near cloud base because of the small updraft velocity near that level. Deep convection tends to be suppressed when convective available potential energy is small because of upward reduction of in-cloud moist static energy. Dry environment air significantly reduces in-cloud humidity mainly because of the large entrainment rate in the lower troposphere, which leads to suppression diff --git a/physics/docs/pdftxt/CPT_adv_suite.txt b/physics/docs/pdftxt/CPT_adv_suite.txt index fb4fb8c0a..53887139f 100644 --- a/physics/docs/pdftxt/CPT_adv_suite.txt +++ b/physics/docs/pdftxt/CPT_adv_suite.txt @@ -25,25 +25,18 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or \section sdf_cpt_suite Suite Definition File -The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c FV3_CPT : +The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c suite_SCM_MGCSAW.xml : \code - + - - - fv_sat_adj - - GFS_time_vary_pre GFS_rrtmg_setup GFS_rad_time_vary GFS_phys_time_vary - stochastic_physics - stochastic_physics_sfc @@ -67,11 +60,12 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or GFS_suite_interstitial_1 dcyc2t3 GFS_surface_generic_pre + GFS_surface_composites_pre GFS_suite_interstitial_2 - sfc_ex_coef + sfc_diff GFS_surface_loop_control_part1 sfc_nst_pre sfc_nst @@ -82,6 +76,7 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or + GFS_surface_composites_post dcyc2t3_post sfc_diag sfc_diag_post @@ -119,15 +114,12 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or cs_conv_aw_adj GFS_MP_generic_post sfc_sice_post - - - - - GFS_stochastics + maximum_hourly_diagnostics + \endcode \section cpt_nml_option Namelist Option @@ -160,7 +152,7 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or dspheat = .true. hybedmf = .true. satmedmf = .false. - lheatstrg = .false. + lheatstrg = .true. random_clds = .true. trans_trac = .true. cnvcld = .true. diff --git a/physics/docs/pdftxt/GFSv15_suite.txt b/physics/docs/pdftxt/GFSv15_suite.txt index 428c1c4e7..ca931d614 100644 --- a/physics/docs/pdftxt/GFSv15_suite.txt +++ b/physics/docs/pdftxt/GFSv15_suite.txt @@ -36,25 +36,18 @@ The GFSv15 physics suite uses the parameterizations in the following order: \section sdf_gfsv15 Suite Definition File -The GFSv15 suite uses the parameterizations in the following order, as defined in \c FV3_GFS_v15 : +The GFSv15 suite uses the parameterizations in the following order, as defined in \c suite_SCM_GFS_v15.xml: \code - + - - - fv_sat_adj - - GFS_time_vary_pre GFS_rrtmg_setup GFS_rad_time_vary GFS_phys_time_vary - stochastic_physics - stochastic_physics_sfc @@ -78,11 +71,12 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i GFS_suite_interstitial_1 dcyc2t3 GFS_surface_generic_pre + GFS_surface_composites_pre GFS_suite_interstitial_2 - sfc_ex_coef + sfc_diff GFS_surface_loop_control_part1 sfc_nst_pre sfc_nst @@ -93,6 +87,7 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i + GFS_surface_composites_post dcyc2t3_post sfc_diag sfc_diag_post @@ -106,6 +101,7 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i rayleigh_damp GFS_suite_stateout_update ozphys_2015 + h2ophys GFS_DCNV_generic_pre get_phi_fv3 GFS_suite_interstitial_3 @@ -127,11 +123,6 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i maximum_hourly_diagnostics - - - GFS_stochastics - - \endcode @@ -196,51 +187,51 @@ The GFSv15 suite uses the parameterizations in the following order, as defined i &gfdl_cloud_microphysics_nml sedi_transport = .true. - do_sedi_heat = .false. - rad_snow = .true. - rad_graupel = .true. - rad_rain = .true. - const_vi = .F. - const_vs = .F. - const_vg = .F. - const_vr = .F. - vi_max = 1. - vs_max = 2. - vg_max = 12. - vr_max = 12. - qi_lim = 1. - prog_ccn = .false. - do_qa = .false. - fast_sat_adj = .false. - tau_l2v = 225. - tau_v2l = 150. - tau_g2v = 900. - rthresh = 10.e-6 - dw_land = 0.16 - dw_ocean = 0.10 - ql_gen = 1.0e-3 - ql_mlt = 1.0e-3 - qi0_crt = 8.0E-5 - qs0_crt = 1.0e-3 - tau_i2s = 1000. - c_psaci = 0.05 - c_pgacs = 0.01 - rh_inc = 0.30 - rh_inr = 0.30 - rh_ins = 0.30 - ccn_l = 300. - ccn_o = 100. - c_paut = 0.5 - c_cracw = 0.8 - use_ppm = .false. - use_ccn = .true. - mono_prof = .true. - z_slope_liq = .true. - z_slope_ice = .true. - de_ice = .false. - fix_negative = .true. - icloud_f = 1 - mp_time = 150. + do_sedi_heat = .false. + rad_snow = .true. + rad_graupel = .true. + rad_rain = .true. + const_vi = .F. + const_vs = .F. + const_vg = .F. + const_vr = .F. + vi_max = 1. + vs_max = 2. + vg_max = 12. + vr_max = 12. + qi_lim = 1. + prog_ccn = .false. + do_qa = .false. + fast_sat_adj = .false. + tau_l2v = 225. + tau_v2l = 150. + tau_g2v = 900. + rthresh = 10.e-6 + dw_land = 0.16 + dw_ocean = 0.10 + ql_gen = 1.0e-3 + ql_mlt = 1.0e-3 + qi0_crt = 8.0E-5 + qs0_crt = 1.0e-3 + tau_i2s = 1000. + c_psaci = 0.05 + c_pgacs = 0.01 + rh_inc = 0.30 + rh_inr = 0.30 + rh_ins = 0.30 + ccn_l = 300. + ccn_o = 100. + c_paut = 0.5 + c_cracw = 0.8 + use_ppm = .false. + use_ccn = .true. + mono_prof = .true. + z_slope_liq = .true. + z_slope_ice = .true. + de_ice = .false. + fix_negative = .true. + icloud_f = 1 + mp_time = 150. / \endcode diff --git a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt index cbcf6d849..dab159d71 100644 --- a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt +++ b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt @@ -26,25 +26,18 @@ This physics suite is the same as GFSv15 physics suite with \ref GFS_SATMEDMF r \section sdf_gfsv15p Suite Definition File -The GFSv15plus suite uses the parameterizations in the following order, as defined in \c FV3_GFS_v15plus : +The GFSv15plus suite uses the parameterizations in the following order, as defined in \c suite_SCM_GFS_v15plus.xml : \code - + - - - fv_sat_adj - - GFS_time_vary_pre GFS_rrtmg_setup GFS_rad_time_vary GFS_phys_time_vary - stochastic_physics - stochastic_physics_sfc @@ -68,11 +61,12 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin GFS_suite_interstitial_1 dcyc2t3 GFS_surface_generic_pre + GFS_surface_composites_pre GFS_suite_interstitial_2 - sfc_ex_coef + sfc_diff GFS_surface_loop_control_part1 sfc_nst_pre sfc_nst @@ -83,12 +77,13 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin + GFS_surface_composites_post dcyc2t3_post sfc_diag sfc_diag_post GFS_surface_generic_post GFS_PBL_generic_pre - hedmf + satmedmfvdif GFS_PBL_generic_post gwdps_pre gwdps @@ -96,6 +91,7 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin rayleigh_damp GFS_suite_stateout_update ozphys_2015 + h2ophys GFS_DCNV_generic_pre get_phi_fv3 GFS_suite_interstitial_3 @@ -117,11 +113,6 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin maximum_hourly_diagnostics - - - GFS_stochastics - - \endcode @@ -186,51 +177,51 @@ The GFSv15plus suite uses the parameterizations in the following order, as defin &gfdl_cloud_microphysics_nml sedi_transport = .true. - do_sedi_heat = .false. - rad_snow = .true. - rad_graupel = .true. - rad_rain = .true. - const_vi = .F. - const_vs = .F. - const_vg = .F. - const_vr = .F. - vi_max = 1. - vs_max = 2. - vg_max = 12. - vr_max = 12. - qi_lim = 1. - prog_ccn = .false. - do_qa = .false. - fast_sat_adj = .false. - tau_l2v = 225. - tau_v2l = 150. - tau_g2v = 900. - rthresh = 10.e-6 - dw_land = 0.16 - dw_ocean = 0.10 - ql_gen = 1.0e-3 - ql_mlt = 1.0e-3 - qi0_crt = 8.0E-5 - qs0_crt = 1.0e-3 - tau_i2s = 1000. - c_psaci = 0.05 - c_pgacs = 0.01 - rh_inc = 0.30 - rh_inr = 0.30 - rh_ins = 0.30 - ccn_l = 300. - ccn_o = 100. - c_paut = 0.5 - c_cracw = 0.8 - use_ppm = .false. - use_ccn = .true. - mono_prof = .true. - z_slope_liq = .true. - z_slope_ice = .true. - de_ice = .false. - fix_negative = .true. - icloud_f = 1 - mp_time = 150. + do_sedi_heat = .false. + rad_snow = .true. + rad_graupel = .true. + rad_rain = .true. + const_vi = .F. + const_vs = .F. + const_vg = .F. + const_vr = .F. + vi_max = 1. + vs_max = 2. + vg_max = 12. + vr_max = 12. + qi_lim = 1. + prog_ccn = .false. + do_qa = .false. + fast_sat_adj = .false. + tau_l2v = 225. + tau_v2l = 150. + tau_g2v = 900. + rthresh = 10.e-6 + dw_land = 0.16 + dw_ocean = 0.10 + ql_gen = 1.0e-3 + ql_mlt = 1.0e-3 + qi0_crt = 8.0E-5 + qs0_crt = 1.0e-3 + tau_i2s = 1000. + c_psaci = 0.05 + c_pgacs = 0.01 + rh_inc = 0.30 + rh_inr = 0.30 + rh_ins = 0.30 + ccn_l = 300. + ccn_o = 100. + c_paut = 0.5 + c_cracw = 0.8 + use_ppm = .false. + use_ccn = .true. + mono_prof = .true. + z_slope_liq = .true. + z_slope_ice = .true. + de_ice = .false. + fix_negative = .true. + icloud_f = 1 + mp_time = 150. / \endcode diff --git a/physics/docs/pdftxt/GSD_THOMPSON.txt b/physics/docs/pdftxt/GSD_THOMPSON.txt index d3ef00dd4..2598d3174 100644 --- a/physics/docs/pdftxt/GSD_THOMPSON.txt +++ b/physics/docs/pdftxt/GSD_THOMPSON.txt @@ -1,6 +1,6 @@ /** -\page GSD_THOMPSON Thompson Aerosol-Aware Microphysics Scheme -\section thompson_descrp Description +\page GSD_THOMPSON Aerosol-Aware Thompson Microphysics Scheme +\section thompson_descrp Description The GSD RAP/HRRR microphysics implementation represents the most aggressive attempt to include explicit prediction of diff --git a/physics/docs/pdftxt/GSD_adv_suite.txt b/physics/docs/pdftxt/GSD_adv_suite.txt index 3d1b79f1d..16de26c63 100644 --- a/physics/docs/pdftxt/GSD_adv_suite.txt +++ b/physics/docs/pdftxt/GSD_adv_suite.txt @@ -40,11 +40,11 @@ The advanced GSD RAP/HRRR physics suite uses the parameterizations in the follow \section sdf_gsdsuite Suite Definition File -The GSD RAP/HRRR physics suite uses the parameterizations in the following order, as defined in \c FV3_GSD: +The GSD RAP/HRRR physics suite uses the parameterizations in the following order, as defined in \c suite_SCM_GSD_v0.xml : \code - + @@ -52,8 +52,6 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order GFS_rrtmg_setup GFS_rad_time_vary GFS_phys_time_vary - stochastic_physics - stochastic_physics_sfc @@ -79,11 +77,12 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order GFS_suite_interstitial_1 dcyc2t3 GFS_surface_generic_pre + GFS_surface_composites_pre GFS_suite_interstitial_2 - sfc_ex_coef + sfc_diff GFS_surface_loop_control_part1 sfc_nst_pre sfc_nst @@ -93,6 +92,7 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order + GFS_surface_composites_post dcyc2t3_post sfc_diag sfc_diag_post @@ -124,11 +124,7 @@ The GSD RAP/HRRR physics suite uses the parameterizations in the following order mp_thompson_post GFS_MP_generic_post cu_gf_driver_post - - - - - GFS_stochastics + maximum_hourly_diagnostics diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/gfdl_fv_sat_adj.F90 index b4b273595..32f360034 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/gfdl_fv_sat_adj.F90 @@ -227,7 +227,7 @@ subroutine fv_sat_adj_finalize (errmsg, errflg) end subroutine fv_sat_adj_finalize -!>\defgroup fast_sat_adj GFDL In-Core Fast Saturation Adjustment +!>\defgroup fast_sat_adj GFDL In-Core Fast Saturation Adjustment Module !> @{ !! The subroutine 'fv_sat_adj' implements the fast processes in the GFDL !! Cloud MP. It is part of the GFDL Cloud MP. diff --git a/physics/gwdc.f b/physics/gwdc.f index d25e8b533..48e78cb44 100644 --- a/physics/gwdc.f +++ b/physics/gwdc.f @@ -116,8 +116,7 @@ module gwdc subroutine gwdc_init() end subroutine gwdc_init -! \defgroup GFS_cgwd GFS Convective Gravity Wave Drag -!> \defgroup GFS_gwdc_run GFS gwdc Main +!> \defgroup GFS_gwdc_run GFS Convective Gravity Wave Drag Scheme Module !! \brief This subroutine is the parameterization of convective gravity wave !! drag based on the theory given by Chun and Baik (1998) !! \cite chun_and_baik_1998 modified for implementation into the diff --git a/physics/gwdps.f b/physics/gwdps.f index 8784a2f6d..ab81603e6 100644 --- a/physics/gwdps.f +++ b/physics/gwdps.f @@ -150,7 +150,7 @@ module gwdps subroutine gwdps_init() end subroutine gwdps_init -!> \defgroup gfs_gwdps GFS gwdps Main +!> \defgroup gfs_gwdps GFS Orographic Gravity Wave Drag and Mountain Blocking Scheme Module !! \brief This subroutine includes orographic gravity wave drag and mountain !! blocking. !! diff --git a/physics/h2ophys.f b/physics/h2ophys.f index 51e3a6051..287cfa3d3 100644 --- a/physics/h2ophys.f +++ b/physics/h2ophys.f @@ -19,7 +19,7 @@ module h2ophys subroutine h2ophys_init() end subroutine h2ophys_init -!>\defgroup GFS_h2ophys GFS h2ophys Main +!>\defgroup GFS_h2ophys GFS Water Vapor Photochemical Production and Loss Module !> This subroutine is NRL H2O physics for stratosphere and mesosphere. !! \section arg_table_h2ophys_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index f973842f0..4edeec95e 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -137,7 +137,7 @@ end subroutine m_micro_init subroutine m_micro_finalize end subroutine m_micro_finalize -!> \defgroup mg2mg3 CPT Morrison-Gettelman MP scheme Module +!> \defgroup mg2mg3 Morrison-Gettelman MP scheme Module !! This module contains the the entity of MG2 and MG3 schemes. !> @{ !> \defgroup mg_driver Morrison-Gettelman MP Driver Module @@ -764,7 +764,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !======================================================================================================================= !======================================================================================================================= !> -# Nucleation of cloud droplets and ice crystals -!! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and nenes (2005) or Abdul Razzak and Ghan (2002) +!! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and Nenes (2005) or Abdul Razzak and Ghan (2002) !! liquid Activation Parameterization !! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). !! Written by Donifan Barahona and described in Barahona et al. (2013) @@ -794,7 +794,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & AERMASSMIX(:,:,1:5) = 1.e-6 AERMASSMIX(:,:,6:15) = 2.e-14 end if -!> - Call aerConversion1() +!> - Call aerconversion1() call AerConversion1 (AERMASSMIX, AeroProps) deallocate(AERMASSMIX) @@ -866,7 +866,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! ==================================================================== -!> -# Call gw_prof() to Calculate subgrid scale distribution in vertical velocity +!> -# Call gw_prof() to calculate subgrid scale distribution in vertical velocity ! ==================================================================== @@ -885,7 +885,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & wparc_cgw(k) = 0.0 end do -!> - Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep +!> - Subgrid variability from convective sources according to Barahona et al. 2014 (in preparation) if (kcldtopcvn > 20) then @@ -946,7 +946,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & -!> - Compute Total variance +!> - Compute total variance do K = 1, LM swparc(k) = sqrt(wparc_gw(k) * wparc_gw(k) & @@ -986,7 +986,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! &,' ccn_param=',ccn_param,' in_param=',in_param & ! &,' AeroAux%kap=',AeroAux%kap -!> -# Call aerosol_activate() to activate the aerosols. +!> -# Call aerosol_activate() to activate the aerosols call aerosol_activate(tauxr8, plevr8(K), swparc(K), & & wparc_ls(K), AeroAux, npre8(k), dpre8(k), ccn_diag, & & ndropr8(k), npccninr8(K), smaxliq(K), & @@ -1081,7 +1081,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !===========================End cloud particle nucleation======================= ! ----------------------------- ! -!> -# Begin Cloud Macrophysics +!> -# Begin cloud macrophysics ! do k=1,lm ! do i=1,im @@ -1145,7 +1145,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & ! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, FRLAND, & -!> - Call macro_cloud() for cloud macrophysics. +!> - Call macro_cloud() for cloud macrophysics call macro_cloud (IM, LM, DT_MOIST, alf_fac, PLO, PLE, & & CNV_DQLDT, & ! & CNV_MFD, CNV_DQLDT, & @@ -1215,7 +1215,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & !============ Put cloud fraction back in contact with the PDF (Barahona et al., GMD, 2014)============ !make sure QI , NI stay within T limits -!> - Call meltfrz_inst() to calculate instantaneous freezing or condensate. +!> - Call meltfrz_inst() to calculate instantaneous freezing or condensate call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) @@ -1345,6 +1345,7 @@ subroutine m_micro_run( im, ix, lm, flipv, dt_i & ! else ! call init_Aer(AeroAux) ! end if +!> - Call getinsubset() to extract dust properties call getINsubset(1, AeroAux, AeroAux_b) naux = AeroAux_b%nmods if (nbincontactdust < naux) then diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 3638dcf1b..46ee57d3d 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -4,27 +4,35 @@ !WRF:MODEL_LAYER:PHYSICS ! -!>\defgroup gsd_mynn_edmf GSD MYNN-EDMF PBL Scheme -!! This module is translated from Nakanishi and Niino (2009) \cite NAKANISHI_2009 -!! f77 to F90 and put into WRF by Mariusz Pagowski -!! NOAA/GSD & CIRA/CSU, Feb 2008. -!! Changes to original code: -!! -# code is 1D (in z) -!! -# no advection of TKE, covariances and variances +!>\defgroup gsd_mynn_edmf GSD MYNN-EDMF PBL Scheme Module +!! The MYNN-EDMF scheme (Olson et al. 2019 \cite olson_et_al_2019) represents the local +!! mixing using an eddy-diffusivity approach tied to turbulent kinetic energy (TKE). +!! The nonlocal mixing, important for convective boundary layers, is represented using +!! a mass-flux approach. The scheme can be run with either a 2.5 or 3.0 closure and includes +!! a partial-condensation scheme, commonly referred to as a cloud PDF or statistical-cloud +!! scheme, to represent the effects of subgrid-scale (SGS) clouds on buoyancy. +!! This module was originally translated from Nakanishi and Niino (2009) \cite NAKANISHI_2009 +!! and put into the WRF model by Mariusz Pagowski NOAA/GSD and CIRA/CSU in 2008. It was +!! extensively modified by Joseph Olson and Jaymes Kenyon of NOAA/GSD and CU/CIRES. +!! +!! Changes to original code introduced by M. Pagowski in 2008: +!! -# Code is 1D (in z) +!! -# No advection of TKE, covariances and variances !! -# Cranck-Nicholson replaced with the implicit scheme -!! -# removed terrain dependent grid since input in WRF in actual distances in z[m] -!! -# cosmetic changes to adhere to WRF standard (remove common blocks, intent etc) +!! -# Removed terrain dependent grid since input in WRF in actual distances in z[m] +!! -# Cosmetic changes to adhere to WRF standard (remove common blocks, intent etc) !! -!!Modifications implemented by Joseph Olson and Jaymes Kenyon NOAA/GSD/MDB - CU/CIRES +!! Further modifications implemented by J. Olson and J. Kenyon: !! !! Departures from original MYNN (Nakanish and Niino (2009) \cite NAKANISHI_2009) -!! -# Addition of BouLac mixing length in the free atmosphere. +!! -# Added the of BouLac mixing length in the free atmosphere. !! -# Changed the turbulent mixing length to be integrated from the -!! surface to the top of the BL + a transition layer depth. +!! surface to the top of the BL plus a transition layer depth. !! +!! Changes made in various versions of the WRF model: !!\version v3.4.1: !! - Option to use Kitamura/Canuto modification which removes -!! the critical Richardson number and negative TKE (default). +!! the critical Richardson number and negative TKE (default) !! - Hybrid PBL height diagnostic, which blends a theta-v-based !! definition in neutral/convective BL and a TKE-based definition !! in stable conditions. @@ -32,7 +40,7 @@ !!\version v3.5.0: !! - TKE advection option (bl_mynn_tkeadvect) !!\version v3.5.1: -!! - Fog deposition related changes. +!! - Fog deposition related changes !!\version v3.6.0: !! - Removed fog deposition from the calculation of tendencies !! - Added mixing of qc, qi, qni @@ -40,10 +48,10 @@ !! coupling to shcu schemes !!\version v3.8.0: !! - Added subgrid scale cloud output for coupling to radiation -!! schemes (activated by setting icloud_bl =1 in phys namelist). +!! schemes (activated by setting icloud_bl =1 in phys namelist) !! - Added WRF_DEBUG prints (at level 3000) -!! - Added Tripoli and Cotton (1981) \cite Tripoli_1981 correction. -!! - Added namelist option bl_mynn_cloudmix to test effect of mixing cloud species (default = 1: on). +!! - Added Tripoli and Cotton (1981) \cite Tripoli_1981 correction +!! - Added namelist option bl_mynn_cloudmix to test effect of mixing cloud species (default = 1: on) !! - Added mass-flux option (bl_mynn_edmf, = 1 for DMP mass-flux, 0: off). Related options: !! - bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme !! - bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme @@ -52,56 +60,56 @@ !! - Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau !! and Bechtold (2002) \cite Chaboureau_2002 with modifications !! - Added capability to mix chemical species when env variable -!! WRF_CHEM = 1, thanks to Wayne Angevine. +!! WRF_CHEM = 1, thanks to Wayne Angevine !! - Added scale-aware mixing length, following Junshi Ito's work -!! Ito et al. (2015, BLM) \cite Ito_2015. +!! Ito et al. (2015, BLM) \cite Ito_2015 !!\version v3.9.0: !! - Improvement to the mass-flux scheme (dynamic number of plumes, -!! better plume/cloud depth, significant speed up, better cloud fraction). -!! - Added Stochastic Parameter Perturbation (SPP) implementation. +!! better plume/cloud depth, significant speed up, better cloud fraction) +!! - Added Stochastic Parameter Perturbation (SPP) implementation !! - Many miscellaneous tweaks to the mixing lengths and stratus -!! component of the subgrid clouds. +!! component of the subgrid clouds !!\version v4.0: !! - Removed or added alternatives to WRF-specific functions/modules -!! for the sake of portability to other models. +!! for the sake of portability to other models !! - Further refinement of mass-flux scheme from SCM experiments with !! Wayne Angevine: switch to linear entrainment and back to -!! Simpson and Wiggert-type w-equation. +!! Simpson and Wiggert-type w-equation !! - Addition of TKE production due to radiation cooling at top of -!! clouds (proto-version); not activated by default. +!! clouds (proto-version); not activated by default !! - Some code rewrites to move if-thens out of loops in an attempt to -!! improve computational efficiency. +!! improve computational efficiency !! - New tridiagonal solver, which is supposedly 14% faster and more -!! conservative. Impact seems very small. +!! conservative. Impact seems very small !! - Many miscellaneous tweaks to the mixing lengths and stratus -!! component of the subgrid-scale (SGS) clouds. +!! component of the subgrid-scale (SGS) clouds !!\version v4.1: !! - Big improvements in downward SW radiation due to revision of subgrid clouds -!! - better cloud fraction and subgrid scale mixing ratios. +!! - better cloud fraction and subgrid scale mixing ratios !! - may experience a small cool bias during the daytime now that high -!! SW-down bias is greatly reduced... +!! SW-down bias is greatly reduced !! - Some tweaks to increase the turbulent mixing during the daytime for -!! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact). -!! - Improved ensemble spread from changes to SPP in MYNN +!! bl_mynn_mixlength option 2 to alleviate cool bias (very small impact) +!! - Improved ensemble spread from changes to Stochastic Parameter Perturbation (SPP) in MYNN !! - now perturbing eddy diffusivity and eddy viscosity directly !! - now perturbing background rh (in SGS cloud calc only) !! - now perturbing entrainment rates in mass-flux scheme !! - Added IF checks (within IFDEFS) to protect mixchem code from being used -!! when HRRR smoke is used (no impact on regular non-wrf chem use) -!! - Important bug fix for wrf chem when transporting chemical species in MF scheme +!! when HRRR smoke is used (no impact when WRF-CHEM is not used) +!! - Important bug fix for WRF-CHEM when transporting chemical species in MF scheme !! - Removed 2nd mass-flux scheme (no only bl_mynn_edmf = 1, no option 2) !! - Removed unused stochastic code for mass-flux scheme !! - Changed mass-flux scheme to be integrated on interface levels instead of !! mass levels - impact is small -!! - Added option to mix 2nd moments in MYNN as opposed to the scalar_pblmix option. +!! - Added option to mix second moments in MYNN as opposed to the scalar_pblmix option. !! - activated with bl_mynn_mixscalars = 1; this sets scalar_pblmix = 0 !! - added tridagonal solver used in scalar_pblmix option to duplicate tendencies -!! - this alone changes the interface call considerably from v4.0. +!! - this alone changes the interface call considerably from v4.0 !! - Slight revision to TKE production due to radiation cooling at top of clouds !! - Added the non-Guassian buoyancy flux function of Bechtold and Siebesma (1998) \cite Bechtold_1998 !! - improves TKE in SGS clouds !! - Added heating due to dissipation of TKE (small impact, maybe + 0.1 C daytime PBL temp) -!! - Misc changes made for FV3/MPAS compatibility +!! - Miscellaneous changes made for FV3/MPAS compatibility !! !!Many of these changes are now documented in Olson et al. (2019, !! NOAA Technical Memorandum) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 1113377ba..da5cd2c2a 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -501,22 +501,22 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & !> - From Martin et al. (1994), assign gamma shape parameter mu for cloud !! drops according to general dispersion characteristics (disp=~0.25 -!! for Maritime and 0.45 for Continental). +!! for maritime and 0.45 for continental) !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime !.. to 2 for really dirty air. This not used in 2-moment cloud water !.. scheme and nu_c used instead and varies from 2 to 15 (integer-only). mu_c = MIN(15., (1000.E6/Nt_c + 2.)) -!> - Compute Schmidt number to one-third used numerous times. +!> - Compute Schmidt number to one-third used numerous times Sc3 = Sc**(1./3.) -!> - Compute min ice diam from mass, min snow/graupel mass from diam. +!> - Compute minimum ice diam from mass, min snow/graupel mass from diam D0i = (xm0i/am_i)**(1./bm_i) xm0s = am_s * D0s**bm_s xm0g = am_g * D0g**bm_g -!> - Compute constants various exponents and gamma() assoc with cloud, -!! rain, snow, and graupel. +!> - Compute constants various exponents and gamma() associated with cloud, +!! rain, snow, and graupel do n = 1, 15 cce(1,n) = n + 1. cce(2,n) = bm_r + n + 1. @@ -621,7 +621,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & ogg3 = 1./cgg(3) !+---+-----------------------------------------------------------------+ -!> - Simplify various rate eqns the best we can now. +!> - Simplify various rate equations !+---+-----------------------------------------------------------------+ !> - Compute rain collecting cloud water and cloud ice @@ -629,36 +629,36 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & t1_qr_qi = PI*.25*av_r * crg(9) t2_qr_qi = PI*.25*am_r*av_r * crg(8) -!> - Compute Graupel collecting cloud water +!> - Compute graupel collecting cloud water t1_qg_qc = PI*.25*av_g * cgg(9) -!> - Compute Snow collecting cloud water +!> - Compute snow collecting cloud water t1_qs_qc = PI*.25*av_s -!> - Compute Snow collecting cloud ice +!> - Compute snow collecting cloud ice t1_qs_qi = PI*.25*av_s -!> - Compute Evaporation of rain; ignore depositional growth of rain. +!> - Compute evaporation of rain; ignore depositional growth of rain t1_qr_ev = 0.78 * crg(10) t2_qr_ev = 0.308*Sc3*SQRT(av_r) * crg(11) -!> - Compute Sublimation/depositional growth of snow +!> - Compute sublimation/depositional growth of snow t1_qs_sd = 0.86 t2_qs_sd = 0.28*Sc3*SQRT(av_s) -!> - Compute Melting of snow +!> - Compute melting of snow t1_qs_me = PI*4.*C_sqrd*olfus * 0.86 t2_qs_me = PI*4.*C_sqrd*olfus * 0.28*Sc3*SQRT(av_s) -!> - Compute Sublimation/depositional growth of graupel +!> - Compute sublimation/depositional growth of graupel t1_qg_sd = 0.86 * cgg(10) t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) -!> - Compute Melting of graupel +!> - Compute melting of graupel t1_qg_me = PI*4.*C_cube*olfus * 0.86 * cgg(10) t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) -!> - Compute Constants for helping find lookup table indexes. +!> - Compute constants for helping find lookup table indexes nic2 = NINT(ALOG10(r_c(1))) nii2 = NINT(ALOG10(r_i(1))) nii3 = NINT(ALOG10(Nt_i(1))) @@ -669,7 +669,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & nig3 = NINT(ALOG10(N0g_exp(1))) niIN2 = NINT(ALOG10(Nt_IN(1))) -!> - Create bins of cloud water (from min diameter up to 100 microns). +!> - Create bins of cloud water (from min diameter up to 100 microns) Dc(1) = D0c*1.0d0 dtc(1) = D0c*1.0d0 do n = 2, nbc @@ -677,7 +677,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & dtc(n) = (Dc(n) - Dc(n-1)) enddo -!> - Create bins of cloud ice (from min diameter up to 5x min snow size). +!> - Create bins of cloud ice (from min diameter up to 5x min snow size) xDx(1) = D0i*1.0d0 xDx(nbi+1) = 5.0d0*D0s do n = 2, nbi @@ -689,7 +689,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & dti(n) = xDx(n+1) - xDx(n) enddo -!> - Create bins of rain (from min diameter up to 5 mm). +!> - Create bins of rain (from min diameter up to 5 mm) xDx(1) = D0r*1.0d0 xDx(nbr+1) = 0.005d0 do n = 2, nbr @@ -701,7 +701,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & dtr(n) = xDx(n+1) - xDx(n) enddo -!> - Create bins of snow (from min diameter up to 2 cm). +!> - Create bins of snow (from min diameter up to 2 cm) xDx(1) = D0s*1.0d0 xDx(nbs+1) = 0.02d0 do n = 2, nbs @@ -713,7 +713,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & dts(n) = xDx(n+1) - xDx(n) enddo -!> - Create bins of graupel (from min diameter up to 5 cm). +!> - Create bins of graupel (from min diameter up to 5 cm) xDx(1) = D0g*1.0d0 xDx(nbg+1) = 0.05d0 do n = 2, nbg @@ -725,7 +725,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & dtg(n) = xDx(n+1) - xDx(n) enddo -!> - Create bins of cloud droplet number concentration (1 to 3000 per cc). +!> - Create bins of cloud droplet number concentration (1 to 3000 per cc) xDx(1) = 1.0d0 xDx(nbc+1) = 3000.0d0 do n = 2, nbc @@ -738,7 +738,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & nic1 = DLOG(t_Nc(nbc)/t_Nc(1)) !+---+-----------------------------------------------------------------+ -!> - Create lookup tables for most costly calculations. +!> - Create lookup tables for most costly calculations !+---+-----------------------------------------------------------------+ ! Assign mpicomm to module variable @@ -876,20 +876,20 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & !> - Call table_ccnact() to read a static file containing CCN activation of aerosols. The !! data were created from a parcel model by Feingold & Heymsfield with -!! further changes by Eidhammer and Kriedenweis. +!! further changes by Eidhammer and Kriedenweis ! This computation is cheap compared to the others below, and ! doing it always ensures that the correct data is in the SIONlib ! file containing the precomputed tables *DH WRITE (*,*) ' calling table_ccnAct routine' call table_ccnAct -!> - Call table_efrw() and table_Efsw() to creat collision efficiency table -!! between rain/snow and cloud water. +!> - Call table_efrw() and table_efsw() to creat collision efficiency table +!! between rain/snow and cloud water WRITE (*,*)' creating qc collision eff tables' call table_Efrw call table_Efsw -!> - Call table_dropevap() to creat rain drop evaporation table. +!> - Call table_dropevap() to creat rain drop evaporation table WRITE(*,*) ' creating rain evap table' call table_dropEvap @@ -898,7 +898,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & end if precomputed_tables_1 -!> - Call radar_init() to initialize various constants for computing radar reflectivity. +!> - Call radar_init() to initialize various constants for computing radar reflectivity call cpu_time(stime) xam_r = am_r xbm_r = bm_r @@ -925,7 +925,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & !$OMP sections !$OMP section -!> - Call qr_acr_qg() to create rain collecting graupel & graupel collecting rain table. +!> - Call qr_acr_qg() to create rain collecting graupel & graupel collecting rain table WRITE (*,*) ' creating rain collecting graupel table' call cpu_time(stime) call qr_acr_qg @@ -933,7 +933,7 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & if (mpirank==mpiroot) print '("Computing rain collecting graupel table took ",f10.3," seconds.")', etime-stime !$OMP section -!> - Call qr_acr_qs() to create rain collecting snow & snow collecting rain table. +!> - Call qr_acr_qs() to create rain collecting snow & snow collecting rain table WRITE (*,*) ' creating rain collecting snow table' call cpu_time(stime) call qr_acr_qs @@ -944,14 +944,14 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & !$OMP end parallel -!> - Call freezeh2o() to create cloud water and rain freezing (Bigg, 1953) table. +!> - Call freezeh2o() to create cloud water and rain freezing (Bigg, 1953) table WRITE (*,*) ' creating freezing of water drops table' call cpu_time(stime) call freezeH2O(threads) call cpu_time(etime) if (mpirank==mpiroot) print '("Computing freezing of water drops table took ",f10.3," seconds.")', etime-stime -!> - Call qi_aut_qs() to create conversion of some ice mass into snow category. +!> - Call qi_aut_qs() to create conversion of some ice mass into snow category WRITE (*,*) ' creating ice converting to snow table' call cpu_time(stime) call qi_aut_qs @@ -989,7 +989,6 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & endif if_micro_init END SUBROUTINE thompson_init - !> @} !>\ingroup aathompson @@ -3697,7 +3696,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo end subroutine mp_thompson -! >@} +!>@} + !+---+-----------------------------------------------------------------+ !ctrlL !+---+-----------------------------------------------------------------+ @@ -4757,9 +4757,11 @@ end function activ_ncloud !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ !>\ingroup aathompson +!! Returns the incomplete gamma function q(a,x) evaluated by its +!! continued fraction representation as gammcf. SUBROUTINE GCF(GAMMCF,A,X,GLN) -!> RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS -!! CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS +! RETURNS THE INCOMPLETE GAMMA FUNCTION Q(A,X) EVALUATED BY ITS +! CONTINUED FRACTION REPRESENTATION AS GAMMCF. ALSO RETURNS ! --- LN(GAMMA(A)) AS GLN. THE CONTINUED FRACTION IS EVALUATED BY ! --- A MODIFIED LENTZ METHOD. ! --- USES GAMMLN @@ -4794,6 +4796,8 @@ END SUBROUTINE GCF ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !>\ingroup aathompson +!! Returns the incomplete gamma function p(a,x) evaluated by +!! its series representation as gamser. SUBROUTINE GSER(GAMSER,A,X,GLN) ! --- RETURNS THE INCOMPLETE GAMMA FUNCTION P(A,X) EVALUATED BY ITS ! --- ITS SERIES REPRESENTATION AS GAMSER. ALSO RETURNS LN(GAMMA(A)) @@ -4827,6 +4831,7 @@ END SUBROUTINE GSER ! (C) Copr. 1986-92 Numerical Recipes Software 2.02 !>\ingroup aathompson +!! Returns the value ln(gamma(xx)) for xx > 0. REAL FUNCTION GAMMLN(XX) ! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. IMPLICIT NONE diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index 37a574495..be2a74957 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -2,8 +2,8 @@ !! This file is the entity of NOAA/ESRL/GSD RUC LSM Model(WRF version 4.0). !>\ingroup lsm_ruc_group -!!\brief This is the entity of RUC LSM model of physics subroutines. -!! It is a soil/veg/snowpack and ice/snowpack/land-surface model to update soil +!! This module contains the entity of the RUC LSM model, which is a +!! soil/veg/snowpack and ice/snowpack/land-surface model to update soil !! moisture, soil temperature, skin temperature, snowpack water content, snowdepth, !! and all terms of the surface energy balance and surface water balance. MODULE module_sf_ruclsm @@ -7678,8 +7678,8 @@ END SUBROUTINE SOILIN !+---+-----------------------------------------------------------------+ !>\ingroup lsm_ruc_group -!> THIS FUNCTION CALCULATES THE LIQUID SATURATION VAPOR MIXING RATIO AS -!! A FUNCTION OF TEMPERATURE AND PRESSURE (from Thompson scheme) +!> This function calculates the liquid saturation vapor mixing ratio as +!! a function of temperature and pressure (from Thompson scheme). REAL FUNCTION RSLF(P,T) IMPLICIT NONE diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 918255a12..363484457 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -16,7 +16,7 @@ subroutine hedmf_finalize () end subroutine hedmf_finalize -!> \defgroup HEDMF GFS moninedmf Main +!> \defgroup HEDMF GFS Hybrid Eddy-Diffusivity Mass-Flux (HEDMF) Scheme Module !! @{ !! \brief This subroutine contains all of logic for the !! Hybrid EDMF PBL scheme except for the calculation of diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index f54cee0e5..df4a5de73 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -1,11 +1,9 @@ !>\file mp_thompson.F90 -!! This file contains NOAA/GSD's Thompson MP scheme. +!! This file contains aerosol-aware Thompson MP scheme. -!>\defgroup aathompson GSD Aerosol-Aware Thompson MP Module -!! -!! Last modified 4 Apr 2019: remove legacy debugging code D. Heinzeller -!> @{ +!>\defgroup aathompson Aerosol-Aware Thompson MP Module +!! This module contains the aerosol-aware Thompson microphysics scheme. module mp_thompson use machine, only : kind_phys @@ -496,4 +494,3 @@ subroutine mp_thompson_finalize(errmsg, errflg) end subroutine mp_thompson_finalize end module mp_thompson -!> @} diff --git a/physics/ozphys_2015.f b/physics/ozphys_2015.f index 6eceaf203..0e7e11484 100644 --- a/physics/ozphys_2015.f +++ b/physics/ozphys_2015.f @@ -20,7 +20,7 @@ subroutine ozphys_2015_finalize() end subroutine ozphys_2015_finalize -!>\defgroup GFS_ozphys_2015 GFS ozphys_2015 Main +!>\defgroup GFS_ozphys_2015 GFS Ozone Photochemistry (2015) Scheme Module !! \brief The operational GFS currently parameterizes ozone production and !! destruction based on monthly mean coefficients ( !! \c ozprdlos_2015_new_sbuvO3_tclm15_nuchem.f77) provided by Naval diff --git a/physics/radiation_aerosols.f b/physics/radiation_aerosols.f index a6afff5d3..60bb50d34 100644 --- a/physics/radiation_aerosols.f +++ b/physics/radiation_aerosols.f @@ -123,20 +123,6 @@ !! \brief This module contains climatological atmospheric aerosol schemes for !! radiation computations. !! -!! GFS selection for Aerosol distribution (namelist control paramter - \b IAER = 111 -!! and \b IAERMDL =0; not available for the current operational GFS) -!! \n IAERMDL=0: OPAC-climatology tropospheric model (monthly mean, \f$15^o\f$ horizontal resolution) -!! \n IAERMDL=1: GOCART-climatology tropospheric aerosol model -!! \n IAERMDL=2: GOCART-climatology prognostic aerosol model -!! -!!\n \b Stratosphere: historical recorded volcanic forcing in four zonal mean bands (1850-2000) -!!\n \b IAER = abc of 3-digit integer flags: a-volcanic; b-LW; c-SW -!!\n a=0: include background stratospheric volcanic aerosol effect (if both b&c /=0) -!!\n a=1: include recorded stratospheric volcanic aerosol effect -!!\n b=0: no LW tropospheric aerosol effect -!!\n b=1: include LW tropospheric aerosol effect -!!\n c=0: no SW tropospheric aerosol effect -!!\n c=1: include SW tropospheric aerosol effect !! !!\version NCEP-Radiation_aerosols v5.2 Jan 2013 !! diff --git a/physics/radlw_main.f b/physics/radlw_main.f index 23ed429e6..961f92a78 100644 --- a/physics/radlw_main.f +++ b/physics/radlw_main.f @@ -356,7 +356,7 @@ module rrtmg_lw subroutine rrtmg_lw_init () end subroutine rrtmg_lw_init -!> \defgroup module_radlw_main GFS radlw Main +!> \defgroup module_radlw_main GFS RRTMG Longwave Module !! \brief This module includes NCEP's modifications of the RRTMG-LW radiation !! code from AER. !! diff --git a/physics/radsw_main.f b/physics/radsw_main.f index 06c60bac8..628450e06 100644 --- a/physics/radsw_main.f +++ b/physics/radsw_main.f @@ -376,7 +376,7 @@ module rrtmg_sw subroutine rrtmg_sw_init () end subroutine rrtmg_sw_init -!> \defgroup module_radsw_main GFS radsw Main +!> \defgroup module_radsw_main GFS RRTMG Shortwave Module !! This module includes NCEP's modifications of the RRTMG-SW radiation !! code from AER. !! diff --git a/physics/rayleigh_damp.f b/physics/rayleigh_damp.f index 1e5711347..6c2806668 100644 --- a/physics/rayleigh_damp.f +++ b/physics/rayleigh_damp.f @@ -11,7 +11,7 @@ module rayleigh_damp subroutine rayleigh_damp_init () end subroutine rayleigh_damp_init -!>\defgroup rayleigh_main GFS Rayleigh Damping Main +!>\defgroup rayleigh_main GFS Rayleigh Damping Module !!\brief This is the Rayleigh friction calculation with total energy conservation. !! !! Role of Rayleigh friction, it attempts to resolve two issues: diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 4577d96d3..2d444a01e 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -23,7 +23,7 @@ end subroutine samfdeepcnv_init subroutine samfdeepcnv_finalize() end subroutine samfdeepcnv_finalize -!> \defgroup SAMFdeep GFS samfdeepcnv Main +!> \defgroup SAMFdeep GFS Scale-Aware Mass-Flux Deep Convection Scheme Module !! @{ !> \brief This subroutine contains the entirety of the SAMF deep convection !! scheme. diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index de64cf211..3f5bc2c0f 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -23,7 +23,7 @@ subroutine samfshalcnv_finalize() end subroutine samfshalcnv_finalize -!> \defgroup SAMF_shal GFS samfshalcnv Main +!> \defgroup SAMF_shal GFS Scale-Aware Mass-Flux Shallow Convection Scheme Module !! @{ !> \brief This subroutine contains the entirety of the SAMF shallow convection !! scheme. diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 4bf4e2251..0dc7cc0ee 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -12,7 +12,7 @@ end subroutine satmedmfvdif_init subroutine satmedmfvdif_finalize () end subroutine satmedmfvdif_finalize -!> \defgroup satmedmf GFS satmedmfvdif Main +!> \defgroup satmedmf GFS Scale-aware TKE-based Moist Eddy-Diffusivity Mass-flux (TKE-EDMF) Scheme Module !! @{ !! \brief This subroutine contains all of the logic for the !! scale-aware TKE-based moist eddy-diffusion mass-flux (TKE-EDMF) scheme. diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index ff503d3b2..fe53292c0 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -24,7 +24,7 @@ end subroutine sfc_diff_init subroutine sfc_diff_finalize end subroutine sfc_diff_finalize -!> \defgroup GFS_diff_main GFS sfc_diff Main +!> \defgroup GFS_diff_main GFS Surface Layer Scheme Module !> @{ !> \brief This subroutine calculates surface roughness length. !! diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f7899a75d..74a57f291 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -139,7 +139,8 @@ end subroutine lsm_ruc_finalize ! ==================== end of description ===================== ! !> \defgroup lsm_ruc_group GSD RUC LSM Model -!! This module contains GSD RUC Land Surface Model +!! This module contains the RUC Land Surface Model developed by NOAA/GSD +!! (Smirnova et al. 2016 \cite Smirnova_2016). #if 0 !> \section arg_table_lsm_ruc_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index a0e60f380..5dfb71048 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -21,7 +21,7 @@ end subroutine sfc_nst_init subroutine sfc_nst_finalize end subroutine sfc_nst_finalize -!>\defgroup gfs_nst_main GFS sfc_nst Main +!>\defgroup gfs_nst_main GFS Near-Surface Sea Temperature Scheme Module !> \brief This subroutine calls the Thermal Skin-layer and Diurnal Thermocline models to update the NSST profile. !! \section arg_table_sfc_nst_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 19b05f789..ed3581e3f 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -88,7 +88,7 @@ end subroutine sfc_sice_init subroutine sfc_sice_finalize end subroutine sfc_sice_finalize -!>\defgroup gfs_sice_main GFS sfc_sice Main +!>\defgroup gfs_sice_main GFS Three-layer Thermodynomics Sea-Ice Scheme Module !! \brief This is three-layer thermodynomics sea-ice model based on Winton (2000) \cite winton_2000. !! \section arg_table_sfc_sice_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | From a6b84bc0581a0f262681c676cf0215c6fbf4627a Mon Sep 17 00:00:00 2001 From: "Grant.Firl" Date: Mon, 10 Jun 2019 13:08:42 -0600 Subject: [PATCH 05/19] add calculation of cumulative_change_in_X_due_to_PBL to MYNN PBL wrapper --- physics/module_MYNNPBL_wrapper.F90 | 51 +++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 5 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 740948695..4d97c6f24 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -26,7 +26,11 @@ end subroutine mynnedmf_wrapper_finalize !! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | !! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | !! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for 3d diagnostic fields | flag | 0 | logical | | in | F | +!! | lsidea | flag_idealized_physics | flag for idealized physics | flag | 0 | logical | | in | F | !! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | !! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | !! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | !! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | @@ -95,6 +99,14 @@ end subroutine mynnedmf_wrapper_finalize !! | dqdt_ice_num_conc | tendency_of_ice_number_concentration_due_to_model_physics | number conc. of ice tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | !! | dqdt_water_aer_num_conc | tendency_of_water_friendly_aerosol_number_concentration_due_to_model_physics | number conc. of water-friendly aerosols tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | !! | dqdt_ice_aer_num_conc | tendency_of_ice_friendly_aerosol_number_concentration_due_to_model_physics | number conc. of ice-friendly aerosols tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | +!! | dt3dt | cumulative_change_in_temperature_due_to_PBL | cumulative change in temperature due to PBL | K | 2 | real | kind_phys | inout | F | +!! | du3dt_PBL | cumulative_change_in_x_wind_due_to_PBL | cumulative change in x wind due to PBL | m s-1 | 2 | real | kind_phys | inout | F | +!! | du3dt_OGWD | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in x wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt_PBL | cumulative_change_in_y_wind_due_to_PBL | cumulative change in y wind due to PBL | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt_OGWD | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in y wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | htrsw | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep | total sky sw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | htrlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep | total sky lw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | !! | grav_settling | grav_settling | flag to activate gravitational setting of fog | flag | 0 | integer | | in | F | !! | bl_mynn_tkebudget | tke_budget | flag for activating TKE budget | flag | 0 | integer | | in | F | !! | bl_mynn_tkeadvect | tke_advect | flag for activating TKE advect | flag | 0 | logical | | in | F | @@ -121,7 +133,8 @@ end subroutine mynnedmf_wrapper_finalize SUBROUTINE mynnedmf_wrapper_run( & & ix,im,levs, & & flag_init,flag_restart, & - & delt,dx,zorl, & + & lssav, ldiag3d, lsidea, & + & delt,dtf,dx,zorl, & & phii,u,v,omega,t3d, & & qgrs_water_vapor, & & qgrs_liquid_cloud, & @@ -151,6 +164,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & + & dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, & + & htrsw, htrlw, xmu, & & grav_settling, bl_mynn_tkebudget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & & bl_mynn_edmf, bl_mynn_edmf_mom, bl_mynn_edmf_tke, & @@ -246,7 +261,8 @@ SUBROUTINE mynnedmf_wrapper_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + + LOGICAL, INTENT(IN) :: lssav, ldiag3d, lsidea ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay @@ -278,7 +294,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D - REAL(kind=kind_phys), intent(in) :: delt + REAL(kind=kind_phys), intent(in) :: delt, dtf INTEGER, intent(in) :: im, ix, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i @@ -287,6 +303,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & ITS,ITE,JTS,JTE,KTS,KTE INTEGER :: kdvel, num_vert_mix INTEGER, PARAMETER :: nchem=1, ndvel=1 + REAL(kind=kind_phys) :: tem !MYNN-3D real(kind=kind_phys), dimension(im,levs+1), intent(in) :: phii @@ -315,7 +332,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & RTHRATEN real(kind=kind_phys), dimension(im,levs), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m - + real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, & + & du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD + real(kind=kind_phys), dimension(im), intent(in) :: xmu + real(kind=kind_phys), dimension(im, levs), intent(in) :: htrsw, htrlw !LOCAL real(kind=kind_phys), dimension(im,levs) :: & & qvsh,qc,qi,qnc,qni,ozone,qnwfa,qnifa, & @@ -791,7 +811,28 @@ SUBROUTINE mynnedmf_wrapper_run( & enddo enddo endif - + + if (lssav .and. ldiag3d) then + if (lsidea) then + dt3dt(1:im,:) = dt3dt(1:im,:) + dtdt(1:im,:)*dtf + else + do k=1,levs + do i=1,im + tem = dtdt(i,k) - (htrlw(i,k)+htrsw(i,k)*xmu(i)) + dt3dt(i,k) = dt3dt(i,k) + tem*dtf + enddo + enddo + endif + do k=1,levs + do i=1,im + du3dt_PBL(i,k) = du3dt_PBL(i,k) + dudt(i,k) * dtf + du3dt_OGWD(i,k) = du3dt_OGWD(i,k) - dudt(i,k) * dtf + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + dvdt(i,k) * dtf + dv3dt_OGWD(i,k) = dv3dt_OGWD(i,k) - dvdt(i,k) * dtf + enddo + enddo + endif + if (lprnt) then print* print*,"===Finished with mynn_bl_driver; output:" From 55d46a1eeccadf9a4acffcb6fddafae74a84d8e5 Mon Sep 17 00:00:00 2001 From: "Grant.Firl" Date: Tue, 11 Jun 2019 13:12:40 -0600 Subject: [PATCH 06/19] add calculation of cumulative_change_in_X_due_to_PBL to MYNN PBL wrapper --- physics/module_MYNNPBL_wrapper.F90 | 51 +++++++++++++++++++++++++++--- 1 file changed, 46 insertions(+), 5 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 740948695..4d97c6f24 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -26,7 +26,11 @@ end subroutine mynnedmf_wrapper_finalize !! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | !! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | !! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for 3d diagnostic fields | flag | 0 | logical | | in | F | +!! | lsidea | flag_idealized_physics | flag for idealized physics | flag | 0 | logical | | in | F | !! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | !! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | !! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | !! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | @@ -95,6 +99,14 @@ end subroutine mynnedmf_wrapper_finalize !! | dqdt_ice_num_conc | tendency_of_ice_number_concentration_due_to_model_physics | number conc. of ice tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | !! | dqdt_water_aer_num_conc | tendency_of_water_friendly_aerosol_number_concentration_due_to_model_physics | number conc. of water-friendly aerosols tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | !! | dqdt_ice_aer_num_conc | tendency_of_ice_friendly_aerosol_number_concentration_due_to_model_physics | number conc. of ice-friendly aerosols tendency due to model physics | kg-1 s-1 | 2 | real | kind_phys | inout | F | +!! | dt3dt | cumulative_change_in_temperature_due_to_PBL | cumulative change in temperature due to PBL | K | 2 | real | kind_phys | inout | F | +!! | du3dt_PBL | cumulative_change_in_x_wind_due_to_PBL | cumulative change in x wind due to PBL | m s-1 | 2 | real | kind_phys | inout | F | +!! | du3dt_OGWD | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in x wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt_PBL | cumulative_change_in_y_wind_due_to_PBL | cumulative change in y wind due to PBL | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt_OGWD | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in y wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | htrsw | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep | total sky sw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | htrlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep | total sky lw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | !! | grav_settling | grav_settling | flag to activate gravitational setting of fog | flag | 0 | integer | | in | F | !! | bl_mynn_tkebudget | tke_budget | flag for activating TKE budget | flag | 0 | integer | | in | F | !! | bl_mynn_tkeadvect | tke_advect | flag for activating TKE advect | flag | 0 | logical | | in | F | @@ -121,7 +133,8 @@ end subroutine mynnedmf_wrapper_finalize SUBROUTINE mynnedmf_wrapper_run( & & ix,im,levs, & & flag_init,flag_restart, & - & delt,dx,zorl, & + & lssav, ldiag3d, lsidea, & + & delt,dtf,dx,zorl, & & phii,u,v,omega,t3d, & & qgrs_water_vapor, & & qgrs_liquid_cloud, & @@ -151,6 +164,8 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & + & dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, & + & htrsw, htrlw, xmu, & & grav_settling, bl_mynn_tkebudget, bl_mynn_tkeadvect, & & bl_mynn_cloudpdf, bl_mynn_mixlength, & & bl_mynn_edmf, bl_mynn_edmf_mom, bl_mynn_edmf_tke, & @@ -246,7 +261,8 @@ SUBROUTINE mynnedmf_wrapper_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - + + LOGICAL, INTENT(IN) :: lssav, ldiag3d, lsidea ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & lprnt, do_mynnsfclay @@ -278,7 +294,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni !MYNN-1D - REAL(kind=kind_phys), intent(in) :: delt + REAL(kind=kind_phys), intent(in) :: delt, dtf INTEGER, intent(in) :: im, ix, levs LOGICAL, intent(in) :: flag_init, flag_restart INTEGER :: initflag, k, i @@ -287,6 +303,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & ITS,ITE,JTS,JTE,KTS,KTE INTEGER :: kdvel, num_vert_mix INTEGER, PARAMETER :: nchem=1, ndvel=1 + REAL(kind=kind_phys) :: tem !MYNN-3D real(kind=kind_phys), dimension(im,levs+1), intent(in) :: phii @@ -315,7 +332,10 @@ SUBROUTINE mynnedmf_wrapper_run( & & RTHRATEN real(kind=kind_phys), dimension(im,levs), intent(out) :: & & Tsq, Qsq, Cov, exch_h, exch_m - + real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, & + & du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD + real(kind=kind_phys), dimension(im), intent(in) :: xmu + real(kind=kind_phys), dimension(im, levs), intent(in) :: htrsw, htrlw !LOCAL real(kind=kind_phys), dimension(im,levs) :: & & qvsh,qc,qi,qnc,qni,ozone,qnwfa,qnifa, & @@ -791,7 +811,28 @@ SUBROUTINE mynnedmf_wrapper_run( & enddo enddo endif - + + if (lssav .and. ldiag3d) then + if (lsidea) then + dt3dt(1:im,:) = dt3dt(1:im,:) + dtdt(1:im,:)*dtf + else + do k=1,levs + do i=1,im + tem = dtdt(i,k) - (htrlw(i,k)+htrsw(i,k)*xmu(i)) + dt3dt(i,k) = dt3dt(i,k) + tem*dtf + enddo + enddo + endif + do k=1,levs + do i=1,im + du3dt_PBL(i,k) = du3dt_PBL(i,k) + dudt(i,k) * dtf + du3dt_OGWD(i,k) = du3dt_OGWD(i,k) - dudt(i,k) * dtf + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + dvdt(i,k) * dtf + dv3dt_OGWD(i,k) = dv3dt_OGWD(i,k) - dvdt(i,k) * dtf + enddo + enddo + endif + if (lprnt) then print* print*,"===Finished with mynn_bl_driver; output:" From db66c394d0cfa21d85af4c859212f7e65bcf2117 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Tue, 11 Jun 2019 15:12:24 -0600 Subject: [PATCH 07/19] scidoc updates --- physics/cu_gf_deep.F90 | 218 +++++++++---------- physics/cu_gf_driver.F90 | 7 +- physics/docs/ccppv3_doxyfile | 12 +- physics/docs/library.bib | 72 +++--- physics/docs/pdftxt/CPT_CSAW.txt | 2 +- physics/docs/pdftxt/CPT_MG3.txt | 2 +- physics/docs/pdftxt/CPT_adv_suite.txt | 6 +- physics/docs/pdftxt/GFDL_cloud.txt | 6 +- physics/docs/pdftxt/GFS_GWDC.txt | 6 +- physics/docs/pdftxt/GFS_H2OPHYS.txt | 2 +- physics/docs/pdftxt/GFS_NOAH.txt | 10 +- physics/docs/pdftxt/GFS_SFCLYR.txt | 12 +- physics/docs/pdftxt/GFS_SFCSICE.txt | 4 +- physics/docs/pdftxt/GFS_SURFACE_PERT.txt | 20 +- physics/docs/pdftxt/GFSv15_suite.txt | 19 +- physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt | 8 +- physics/docs/pdftxt/GSD_CU_GF_deep.txt | 21 +- physics/docs/pdftxt/GSD_THOMPSON.txt | 2 +- physics/docs/pdftxt/GSD_adv_suite.txt | 7 +- physics/docs/pdftxt/all_shemes_list.txt | 30 +-- physics/docs/pdftxt/all_shemes_list.txt.FV3 | 110 ++++++++++ physics/docs/pdftxt/suite_input.nml.txt | 12 +- physics/module_sf_ruclsm.F90 | 101 --------- 23 files changed, 347 insertions(+), 342 deletions(-) create mode 100644 physics/docs/pdftxt/all_shemes_list.txt.FV3 diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 338bf4cb1..7bf08e6b7 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -51,57 +51,57 @@ module cu_gf_deep !> @{ subroutine cu_gf_deep_run( & itf,ktf,its,ite, kts,kte & - ,dicycle & !< diurnal cycle flag - ,ichoice & !< choice of closure, use "0" for ensemble average - ,ipr & !< this flag can be used for debugging prints - ,ccn & !< not well tested yet - ,dtime & !< - ,imid & !< flag to turn on mid level convection - ,kpbl & !< level of boundary layer height - ,dhdt & !< boundary layer forcing (one closure for shallow) - ,xland & !< land mask - ,zo & !< heights above surface - ,forcing & !< only diagnostic - ,t & !< t before forcing - ,q & !< q before forcing - ,z1 & !< terrain - ,tn & !< t including forcing - ,qo & !< q including forcing - ,po & !< pressure (mb) - ,psur & !< surface pressure (mb) - ,us & !< u on mass points - ,vs & !< v on mass points - ,rho & !< density - ,hfx & !< w/m2, positive upward - ,qfx & !< w/m2, positive upward - ,dx & !< dx is grid point dependent here - ,mconv & !< integrated vertical advection of moisture - ,omeg & !< omega (pa/s) - ,csum & !< used to implement memory, set to zero if not avail - ,cnvwt & !< gfs needs this - ,zuo & !< nomalized updraft mass flux - ,zdo & !< nomalized downdraft mass flux - ,zdm & !< nomalized downdraft mass flux from mid scheme - ,edto & !< - ,edtm & !< - ,xmb_out & !< the xmb's may be needed for dicycle - ,xmbm_in & !< - ,xmbs_in & !< - ,pre & !< - ,outu & !< momentum tendencies at mass points - ,outv & !< - ,outt & !< temperature tendencies - ,outq & !< q tendencies - ,outqc & !< ql/qice tendencies - ,kbcon & !< - ,ktop & !< - ,cupclw & !< used for direct coupling to radiation, but with tuning factors - ,ierr & !< ierr flags are error flags, used for debugging - ,ierrc & ! - Call cup_env() to calculate moist static energy, heights, qes ! call cup_env(z,qes,he,hes,t,q,po,z1, & psur,ierr,tcrit,-1, & @@ -558,7 +558,7 @@ subroutine cu_gf_deep_run( & its,ite, kts,kte) ! -!--- environmental values on cloud levels +!> - Call cup_env_clev() to calculate environmental values on cloud levels ! call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & @@ -571,7 +571,7 @@ subroutine cu_gf_deep_run( & itf,ktf, & its,ite, kts,kte) !---meltglac------------------------------------------------- -!--- partition between liq/ice cloud contents +!> - Call get_partition_liq_ice() to calculate partition between liq/ice cloud contents call get_partition_liq_ice(ierr,tn,po_cup,p_liq_ice,melting_layer,& itf,ktf,its,ite,kts,kte,cumulus) !---meltglac------------------------------------------------- @@ -596,7 +596,7 @@ subroutine cu_gf_deep_run( & enddo 25 continue ! -!--- level where detrainment for downdraft starts +!> - Compute the level where detrainment for downdraft starts (\p kdet) ! do k=kts,ktf if(zo_cup(i,k).gt.z_detr+z1(i))then @@ -611,7 +611,7 @@ subroutine cu_gf_deep_run( & ! ! ! -!------- determine level with highest moist static energy content - k22 +!> - Determine level with highest moist static energy content (\p k22) ! start_k22=2 do 36 i=its,itf @@ -627,7 +627,8 @@ subroutine cu_gf_deep_run( & endif 36 continue ! -!--- determine the level of convective cloud base - kbcon +!> - call get_cloud_bc() and cup_kbcon() to determine the +!! level of convective cloud base (\p kbcon) ! do i=its,itf @@ -720,7 +721,7 @@ subroutine cu_gf_deep_run( & endif enddo ! -!-- get normalized mass flux, entrainment and detrainmentrates for updraft +!> - Call rates_up_pdf() to get normalized mass flux, entrainment and detrainmentrates for updraft ! i=0 !- for mid level clouds we do not allow clouds taller than where stability @@ -757,7 +758,7 @@ subroutine cu_gf_deep_run( & endif enddo ! -! calculate mass entrainment and detrainment +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! if(imid.eq.1)then call get_lateral_massflux(itf,ktf, its,ite, kts,kte & @@ -930,7 +931,7 @@ subroutine cu_gf_deep_run( & enddo enddo ! - !--- calculate moisture properties of updraft +!> - Call cup_up_moisture() to calculate moisture properties of updraft ! if(imid.eq.1)then call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo, & @@ -1250,7 +1251,7 @@ subroutine cu_gf_deep_run( & endif enddo ! -!--- calculate moisture properties of downdraft +!> - Call cup_dd_moisture() to calculate moisture properties of downdraft ! call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, & pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, & @@ -1286,7 +1287,7 @@ subroutine cu_gf_deep_run( & enddo enddo ! -!--- calculate workfunctions for updrafts +!> - Call cup_up_aa0() to calculate workfunctions for updrafts ! call cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & kbcon,ktop,ierr, & @@ -1353,6 +1354,7 @@ subroutine cu_gf_deep_run( & t_star=1. !-- calculate pcape from bl forcing only +!> - Call cup_up_aa1bl() to calculate ECMWF version diurnal cycle closure call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime, & zo_cup,zuo,dbyo_bl,gammao_cup_bl,tn_cup_bl, & kbcon,ktop,ierr, & @@ -1463,7 +1465,7 @@ subroutine cu_gf_deep_run( & axx(:)=aa1(:) ! -!--- determine downdraft strength in terms of windshear +!> - Call cup_dd_edt() to determine downdraft strength in terms of windshear ! call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, & pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh, & @@ -1473,7 +1475,8 @@ subroutine cu_gf_deep_run( & if(ierr(i)/=0)cycle edto(i)=edtc(i,1) enddo - !--- get melting profile + +!> - Call get_melting_profile() to get melting profile call get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & ,pwo,edto,pwdo,melting & ,itf,ktf,its,ite, kts,kte, cumulus ) @@ -2031,7 +2034,6 @@ end subroutine cu_gf_deep_run !> @} !>\ingroup cu_gf_deep_group -!> This subroutine calculates subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh, & rho,aeroevap,itf,ktf, & @@ -2157,9 +2159,6 @@ subroutine cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, & end subroutine cup_dd_edt !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!!\param ierrc -!!\param zd subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, & gamma_cup,pwev,bu,qrcd, & @@ -2306,8 +2305,17 @@ subroutine cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup, & end subroutine cup_dd_moisture !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!!\param +!!\param z environmental heights +!!\param qes environmental saturation mixing ratio +!!\param he environmental moist static energy +!!\param hes environmental saturation moist static energy +!!\param t environmental temperature +!!\param q environmental mixing ratio +!!\param p environmental pressure +!!\param z1 terrain elevation +!!\param psur surface pressure +!!\param ierr error value, maybe modified in this routine +!!\param tcrit 258.K subroutine cup_env(z,qes,he,hes,t,q,p,z1, & psur,ierr,tcrit,itest, & itf,ktf, & @@ -2320,18 +2328,6 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & itf,ktf, & its,ite, kts,kte ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! qes = environmental saturation mixing ratio - ! t = environmental temp - ! tv = environmental virtual temp - ! p = environmental pressure - ! z = environmental heights - ! he = environmental moist static energy - ! hes = environmental saturation moist static energy - ! psur = surface pressure - ! z1 = terrain elevation - ! ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & @@ -2439,8 +2435,24 @@ subroutine cup_env(z,qes,he,hes,t,q,p,z1, & end subroutine cup_env !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param +!!\param t environmental temperature +!!\param qes environmental saturation mixing ratio +!!\param q environmental mixing ratio +!!\param he environmental moist static energy +!!\param hes environmental saturation moist static energy +!!\param z environmental heights +!!\param p environmental pressure +!!\param qes_cup environmental saturation mixing ratio on cloud levels +!!\param q_cup environmental mixing ratio on cloud levels +!!\param he_cup environmental moist static energy on cloud levels +!!\param hes_cup environmental saturation moist static energy on cloud levels +!!\param z_cup environmental heights on cloud levels +!!\param p_cup environmental pressure on cloud levels +!!\param gamma_cup gamma on cloud levels +!!\param t_cup environmental temperature on cloud levels +!!\param psur surface pressure +!!\param ierr error value, maybe modified in this routine +!!\param z1 terrain elevation subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & ierr,z1, & @@ -2453,26 +2465,6 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & ,intent (in ) :: & itf,ktf, & its,ite, kts,kte - ! - ! ierr error value, maybe modified in this routine - ! q = environmental mixing ratio - ! q_cup = environmental mixing ratio on cloud levels - ! qes = environmental saturation mixing ratio - ! qes_cup = environmental saturation mixing ratio on cloud levels - ! t = environmental temp - ! t_cup = environmental temp on cloud levels - ! p = environmental pressure - ! p_cup = environmental pressure on cloud levels - ! z = environmental heights - ! z_cup = environmental heights on cloud levels - ! he = environmental moist static energy - ! he_cup = environmental moist static energy on cloud levels - ! hes = environmental saturation moist static energy - ! hes_cup = environmental saturation moist static energy on cloud levels - ! gamma_cup = gamma on cloud levels - ! psur = surface pressure - ! z1 = terrain elevation - ! ! real(kind=kind_phys), dimension (its:ite,kts:kte) & ,intent (in ) :: & @@ -2543,8 +2535,6 @@ subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & end subroutine cup_env_clev !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,& xf_ens,axx,forcing,maxens3,mconv,rand_clos, & p_cup,ktop,omeg,zd,zdm,k22,zu,pr_ens,edt,edtm,kbcon, & @@ -2927,8 +2917,6 @@ subroutine cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2 end subroutine cup_forcing_ens_3d !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & hkb,ierr,kbmax,p_cup,cap_max, & ztexec,zqexec, & @@ -3068,8 +3056,6 @@ subroutine cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, & end subroutine cup_kbcon !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_maximi(array,ks,ke,maxx,ierr, & itf,ktf, & its,ite, kts,kte ) @@ -3126,8 +3112,6 @@ subroutine cup_maximi(array,ks,ke,maxx,ierr, & end subroutine cup_maximi !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_minimi(array,ks,kend,kt,ierr, & itf,ktf, & its,ite, kts,kte ) @@ -3943,8 +3927,6 @@ real function satvap(temp2) end function !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group -!> This subroutine calcualtes -!>\param subroutine get_cloud_bc(mzp,array,x_aver,k22,add) implicit none integer, intent(in) :: mzp,k22 @@ -3971,8 +3953,6 @@ subroutine get_cloud_bc(mzp,array,x_aver,k22,add) end subroutine get_cloud_bc !======================================================================================== !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev) implicit none diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 30fe5b8f5..1265a7112 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -1,5 +1,5 @@ !>\file cu_gf_driver.F90 -!! This file is Grell-Freitas cumulus scheme driver. +!! This file is scale-aware Grell-Freitas cumulus scheme driver. module cu_gf_driver @@ -267,7 +267,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & ! tropics(:)=0 ! -!> - tuning constants for radiation coupling +!> - Set tuning constants for radiation coupling ! tun_rad_shall(:)=.02 tun_rad_mid(:)=.15 @@ -556,6 +556,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & do i=its,itf if(xmbs(i).gt.0.)cutens(i)=1. enddo +!> - Call neg_check() for GF shallow convection call neg_check('shallow',ipn,dt,qcheck,outqs,outts,outus,outvs, & outqcs,prets,its,ite,kts,kte,itf,ktf,ktops) endif @@ -637,6 +638,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & qcheck(i,k)=qv(i,k) +outqs(i,k)*dt enddo enddo +!> - Call neg_check() for middle GF convection call neg_check('mid',ipn,dt,qcheck,outqm,outtm,outum,outvm, & outqcm,pretm,its,ite,kts,kte,itf,ktf,ktopm) endif @@ -718,6 +720,7 @@ subroutine cu_gf_driver_run(tottracer,ntrac,garea,im,ix,km,dt,cactiv, & qcheck(i,k)=qv(i,k) +(outqs(i,k)+outqm(i,k))*dt enddo enddo +!> - Call neg_check() for deep GF convection call neg_check('deep',ipn,dt,qcheck,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) ! diff --git a/physics/docs/ccppv3_doxyfile b/physics/docs/ccppv3_doxyfile index fbd18f515..be9bfe1f2 100644 --- a/physics/docs/ccppv3_doxyfile +++ b/physics/docs/ccppv3_doxyfile @@ -120,7 +120,7 @@ INPUT = pdftxt/mainpage.txt \ pdftxt/GFS_GWDC.txt \ pdftxt/GFS_SAMFshal.txt \ pdftxt/GFDL_cloud.txt \ - pdftxt/GFS_SURFACE_PERT.txt \ +### pdftxt/GFS_SURFACE_PERT.txt \ pdftxt/GFS_CALPRECIPTYPE.txt \ ### pdftxt/rad_cld.txt \ pdftxt/CPT_CSAW.txt \ @@ -130,10 +130,10 @@ INPUT = pdftxt/mainpage.txt \ pdftxt/GSD_RUCLSM.txt \ pdftxt/GSD_THOMPSON.txt \ ### pdftxt/GFSphys_namelist.txt \ - pdftxt/GFS_STOCHY_PHYS.txt \ +### pdftxt/GFS_STOCHY_PHYS.txt \ pdftxt/suite_input.nml.txt \ ### in-core MP - ../gfdl_fv_sat_adj.F90 \ +### ../gfdl_fv_sat_adj.F90 \ ### time_vary ../GFS_phys_time_vary.fv3.F90 \ ../ozne_def.f \ @@ -207,12 +207,12 @@ INPUT = pdftxt/mainpage.txt \ ../GFS_MP_generic.F90 \ ../calpreciptype.f90 \ ### stochy - ../GFS_stochastics.F90 \ - ../surface_perturbation.F90 \ +### ../GFS_stochastics.F90 \ +### ../surface_perturbation.F90 \ ### ../../stochastic_physics/stochastic_physics.F90 \ ### CPT ../m_micro.F90 \ - ../micro_mg2_0.F90 \ +### ../micro_mg2_0.F90 \ ../micro_mg3_0.F90 \ ../micro_mg_utils.F90 \ ../cldmacro.F \ diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 96f57cef5..5775c6b7b 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,15 +1,35 @@ %% This BibTeX bibliography file was created using BibDesk. %% http://bibdesk.sourceforge.net/ -%% Created for Man Zhang at 2019-06-06 11:56:03 -0600 +%% Created for Man Zhang at 2019-06-10 16:42:57 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{qu_and_hall_2005, + Author = {X. Qu and A. Hall}, + Date-Added = {2019-06-10 16:41:01 -0600}, + Date-Modified = {2019-06-10 16:42:55 -0600}, + Journal = {J. Climate}, + Pages = {5239-5252}, + Title = {Surface contribution to planetary albedo variability in cryosphere regions}, + Volume = {18}, + Year = {2005}} + +@article{grant_et_al_2000, + Author = {I.F. Grant and A. J. Prata and R. P.Cechet}, + Date-Added = {2019-06-10 16:30:06 -0600}, + Date-Modified = {2019-06-10 16:33:28 -0600}, + Journal = {Journal of Applied Meteorology}, + Pages = {231-244}, + Title = {The impact of the diurnal variation of albedo on the remote sensing of the daily mean albedo of grassland}, + Volume = {39}, + Year = {2000}} + @article{moorthi_and_suarez_1992, - Author = {S. Moorthi and M.J. Suarez }, + Author = {S. Moorthi and M.J. Suarez}, Date-Added = {2019-06-06 17:51:50 +0000}, Date-Modified = {2019-06-06 17:56:00 +0000}, Journal = {Monthly Weather Review}, @@ -1773,12 +1793,12 @@ @article{zeng_and_dickinson_1998 @conference{zheng_et_al_2009, Address = {Omaha, Nebraska}, Author = {W. Zheng and H. Wei and J. Meng and M. Ek and K. Mitchell and J. Derber and X. Zeng and Z. Wang}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBWLi4vLi4vLi4vLi4vLi4vRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGZPEQIgAAAAAAIgAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADT4djXSCsAAANl5rUfSW1wcm92ZW1lbnRfb2ZfTGFuZCMzNjVGRjBGLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2X/D9aQ780AAAAAAAAAAAAFAAMAAAkgAAAAAAAAAAAAAAAAAAAACE5PQUhfTFNNABAACAAA0+ItNwAAABEACAAA1pFSPQAAAAEAEANl5rUAD8YgAA/GDwAGL94AAgBRTWFjaW50b3NoIEhEOlVzZXJzOgBtYW4uemhhbmc6AERlc2t0b3A6AE5PQUhfTFNNOgBJbXByb3ZlbWVudF9vZl9MYW5kIzM2NUZGMEYucGRmAAAOAG4ANgBJAG0AcAByAG8AdgBlAG0AZQBuAHQAXwBvAGYAXwBMAGEAbgBkAF8AUwB1AHIAZgBhAGMAZQBfAFMAawBpAG4AXwBUAGUAbQBwAGUAcgBhAHQAdQByAGUAXwBpAG4AXwBOAEMALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAFdVc2Vycy9tYW4uemhhbmcvRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGYAABMAAS8AABUAAgAQ//8AAAAIAA0AGgAkAH0AAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACoQ==}, Date-Added = {2018-01-26 22:19:06 +0000}, Date-Modified = {2018-01-29 23:51:37 +0000}, Organization = {The 23rd Conference on Weather Analysis and Forecasting (WAF)/19th Conference on Numerical Weather Prediction(NWP)}, Title = {Improvement of land surface skin temperature in NCEP Operational NWP models and its impact on satellite Data Assimilation}, - Year = {2009}} + Year = {2009}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBWLi4vLi4vLi4vLi4vLi4vRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGZPEQIgAAAAAAIgAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADT4djXSCsAAANl5rUfSW1wcm92ZW1lbnRfb2ZfTGFuZCMzNjVGRjBGLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2X/D9aQ780AAAAAAAAAAAAFAAMAAAkgAAAAAAAAAAAAAAAAAAAACE5PQUhfTFNNABAACAAA0+ItNwAAABEACAAA1pFSPQAAAAEAEANl5rUAD8YgAA/GDwAGL94AAgBRTWFjaW50b3NoIEhEOlVzZXJzOgBtYW4uemhhbmc6AERlc2t0b3A6AE5PQUhfTFNNOgBJbXByb3ZlbWVudF9vZl9MYW5kIzM2NUZGMEYucGRmAAAOAG4ANgBJAG0AcAByAG8AdgBlAG0AZQBuAHQAXwBvAGYAXwBMAGEAbgBkAF8AUwB1AHIAZgBhAGMAZQBfAFMAawBpAG4AXwBUAGUAbQBwAGUAcgBhAHQAdQByAGUAXwBpAG4AXwBOAEMALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAFdVc2Vycy9tYW4uemhhbmcvRGVza3RvcC9OT0FIX0xTTS9JbXByb3ZlbWVudF9vZl9MYW5kX1N1cmZhY2VfU2tpbl9UZW1wZXJhdHVyZV9pbl9OQy5wZGYAABMAAS8AABUAAgAQ//8AAAAIAA0AGgAkAH0AAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACoQ==}} @article{chen_et_al_1997, Author = {F. Chen and Z. Janjic and K. Mitchell}, @@ -2017,7 +2037,6 @@ @article{iacono_et_al_2008 @article{grant_2001, Abstract = {A closure for the fluxes of mass, heat, and moisture at cloud base in the cumulus-capped boundary layer is developed. The cloud-base mass flux is obtained from a simplifed turbulence kinetic energy (TKE) budget for the sub-cloud layer, in which cumulus convection is assumed to be associated with a transport of TKE from the sub-cloud layer to the cloud layer.The heat and moisture fluxes are obtained from a jump model based on the virtual-potential-temperature equation. A key part of this parametrization is the parametrization of the virtual-temperature flux at the top of the transition zone between the sub-cloud and cloud layers.It is argued that pressure fluctuations must be responsible for the transport of TKE from the cloud layer to the sub-cloud layer.}, Author = {A. L. M. Grant}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JhbnQvMjAwMS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoiV4IMjAwMS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARgJuNOHLk4AAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyYW50AAAQAAgAANHneLIAAAARAAgAANOHgq4AAAABABgAKIleAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyYW50OgAyMDAxLnBkZgAADgASAAgAMgAwADAAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmFudC8yMDAxLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-06-15 22:11:22 +0000}, Date-Modified = {2018-07-06 19:02:34 +0000}, Doi = {10.1002/qj.49712757209}, @@ -2031,13 +2050,13 @@ @article{grant_2001 Url = {http://dx.doi.org/10.1002/qj.49712757209}, Volume = {127}, Year = {2001}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JhbnQvMjAwMS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoiV4IMjAwMS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARgJuNOHLk4AAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyYW50AAAQAAgAANHneLIAAAARAAgAANOHgq4AAAABABgAKIleAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyYW50OgAyMDAxLnBkZgAADgASAAgAMgAwADAAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmFudC8yMDAxLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1002/qj.49712757209}} @article{zhang_and_wu_2003, Abstract = {Abstract This study uses a 2D cloud-resolving model to investigate the vertical transport of horizontal momentum and to understand the role of a convection-generated perturbation pressure field in the momentum transport by convective systems during part of the Tropical Ocean and Global Atmosphere Coupled Ocean?Atmosphere Response Experiment (TOGA COARE) Intensive Observation Period. It shows that convective updrafts transport a significant amount of momentum vertically. This transport is downgradient in the easterly wind regime, but upgradient during a westerly wind burst. The differences in convective momentum transport between easterly and westerly wind regimes are examined. The perturbation pressure gradient accounts for an important part of the apparent momentum source. In general it is opposite in sign to the product of cloud mass flux and the vertical wind shear, with smaller magnitude. Examination of the dynamic forcing to the pressure field demonstrates that the linear forcing representing the interaction between the convective updrafts and the large-scale wind shear is the dominant term, while the nonlinear forcing is of secondary importance. Thus, parameterization schemes taking into account the linear interaction between the convective updrafts and the large-scale wind shear can capture the essential features of the perturbation pressure field. The parameterization scheme for momentum transport by Zhang and Cho is evaluated using the model simulation data. The parameterized pressure gradient force using the scheme is in excellent agreement with the simulated one. The parameterized apparent momentum source is also in good agreement with the model simulation. Other parameterization methods for the pressure gradient are also discussed.}, Annote = {doi: 10.1175/1520-0469(2003)060<1120:CMTAPP>2.0.CO;2}, Author = {Zhang, Guang J. and Wu, Xiaoqing}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {2003/05/01}, Date-Added = {2016-06-14 23:39:50 +0000}, @@ -2056,13 +2075,13 @@ @article{zhang_and_wu_2003 Url = {http://dx.doi.org/10.1175/1520-0469(2003)060<1120:CMTAPP>2.0.CO;2}, Volume = {60}, Year = {2003}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvWmhhbmcvMjAwMy5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqjuYIMjAwMy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAFrUP9K0L8MAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVpoYW5nAAAQAAgAANHneLIAAAARAAgAANK0kjMAAAABABgAKo7mAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFpoYW5nOgAyMDAzLnBkZgAADgASAAgAMgAwADAAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9aaGFuZy8yMDAzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(2003)060%3C1120:CMTAPP%3E2.0.CO;2}} @article{fritsch_and_chappell_1980, Abstract = {Abstract A parameterization formulation for incorporating the effects of midlatitude deep convection into mesoscale-numerical models is presented. The formulation is based on the hypothesis that the buoyant energy available to a parcel, in combination with a prescribed period of time for the convection to remove that energy, can be used to regulate the amount of convection in a mesoscale numerical model grid element. Individual clouds are represented as entraining moist updraft and downdraft plumes. The fraction of updraft condensate evaporated in moist downdrafts is determined from an empirical relationship between the vertical shear of the horizontal wind and precipitation efficiency. Vertical transports of horizontal momentum and warming by compensating subsidence are included in the parameterization. Since updraft and downdraft areas are sometimes a substantial fraction of mesoscale model grid-element areas, grid-point temperatures (adjusted for convection) are an area-weighted mean of updraft, downdraft and environmental temperatures.}, Annote = {doi: 10.1175/1520-0469(1980)037<1722:NPOCDM>2.0.CO;2}, Author = {Fritsch, J. M. and Chappell, C. F.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1980/08/01}, Date = {1980/08/01}, @@ -2083,12 +2102,12 @@ @article{fritsch_and_chappell_1980 Volume = {37}, Year = {1980}, Year1 = {1980}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvRnJpdHNjaC8xOTgwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAARCuMwgxOTgwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABEKs103xvpgAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHRnJpdHNjaAAAEAAIAADR53iyAAAAEQAIAADTfMQGAAAAAQAYARCuMwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBGcml0c2NoOgAxOTgwLnBkZgAADgASAAgAMQA5ADgAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Gcml0c2NoLzE5ODAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1980)037%3C1722:NPOCDM%3E2.0.CO;2}} @article{bechtold_et_al_2008, Abstract = {Advances in simulating atmospheric variability with the ECMWF model are presented that stem from revisions of the convection and diffusion parametrizations. The revisions concern in particular the introduction of a variable convective adjustment time-scale, a convective entrainment rate proportional to the environmental relative humidity, as well as free tropospheric diffusion coefficients for heat and momentum based on Monin--Obukhov functional dependencies.The forecasting system is evaluated against analyses and observations using high-resolution medium-range deterministic and ensemble forecasts, monthly and seasonal integrations, and decadal integrations with coupled atmosphere-ocean models. The results show a significantly higher and more realistic level of model activity in terms of the amplitude of tropical and extratropical mesoscale, synoptic and planetary perturbations. Importantly, with the higher variability and reduced bias not only the probabilistic scores are improved, but also the midlatitude deterministic scores in the short and medium ranges. Furthermore, for the first time the model is able to represent a realistic spectrum of convectively coupled equatorial Kelvin and Rossby waves, and maintains a realistic amplitude of the Madden--Julian oscillation (MJO) during monthly forecasts. However, the propagation speed of the MJO is slower than observed. The higher tropical tropospheric wave activity also results in better stratospheric temperatures and winds through the deposition of momentum.The partitioning between convective and resolved precipitation is unaffected by the model changes with roughly 62% of the total global precipitation being of the convective type. Finally, the changes in convection and diffusion parametrizations resulted in a larger spread of the ensemble forecasts, which allowed the amplitude of the initial perturbations in the ensemble prediction system to decrease by 30%. Copyright {\copyright} 2008 Royal Meteorological Society}, Author = {Bechtold, Peter and K{\"o}hler, Martin and Jung, Thomas and Doblas-Reyes, Francisco and Leutbecher, Martin and Rodwell, Mark J. and Vitart, Frederic and Balsamo, Gianpaolo}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-06-14 23:11:58 +0000}, Date-Modified = {2016-06-14 23:11:58 +0000}, Doi = {10.1002/qj.289}, @@ -2102,12 +2121,12 @@ @article{bechtold_et_al_2008 Url = {http://dx.doi.org/10.1002/qj.289}, Volume = {134}, Year = {2008}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAobfkIMjAwOC5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAARZce9OEjEwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJlY2h0b2xkABAACAAA0ed4sgAAABEACAAA04TgrAAAAAEAGAAobfkAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQmVjaHRvbGQ6ADIwMDgucGRmAA4AEgAIADIAMAAwADgALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQmVjaHRvbGQvMjAwOC5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://dx.doi.org/10.1002/qj.289}} @article{han_and_pan_2011, Annote = {doi: 10.1175/WAF-D-10-05038.1}, Author = {Han, Jongil and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Weather and Forecasting}, Da = {2011/08/01}, Date = {2011/08/01}, @@ -2128,22 +2147,22 @@ @article{han_and_pan_2011 Volume = {26}, Year = {2011}, Year1 = {2011}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMTEucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMTEucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADC1cfTGvlvAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0xtNzwAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDExLnBkZgAADgASAAgAMgAwADEAMQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAxMS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/WAF-D-10-05038.1}} @article{pan_and_wu_1995, Author = {Pan, H. -L. and W.-S. Wu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Date-Added = {2016-06-14 23:06:41 +0000}, Date-Modified = {2016-06-14 23:06:41 +0000}, Journal = {NMC Office Note, No. 409}, Pages = {40pp}, Title = {Implementing a Mass Flux Convection Parameterization Package for the NMC Medium-Range Forecast Model}, - Year = {1995}} + Year = {1995}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvUGFuLzE5OTUucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAwtTNCDE5OTUucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADCtU/TGvMJAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANQYW4AABAACAAA0ed4sgAAABEACAAA0xtHaQAAAAEAGADC1M0AKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAUGFuOgAxOTk1LnBkZgAADgASAAgAMQA5ADkANQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9QYW4vMTk5NS5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}} @article{grell_1993, Annote = {doi: 10.1175/1520-0493(1993)121<0764:PEOAUB>2.0.CO;2}, Author = {Grell, Georg A.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Booktitle = {Monthly Weather Review}, Da = {1993/03/01}, Date = {1993/03/01}, @@ -2164,11 +2183,11 @@ @article{grell_1993 Volume = {121}, Year = {1993}, Year1 = {1993}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvR3JlbGwvMTk5My5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAoie0IMTk5My5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMK4dtMa9LMAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUdyZWxsAAAQAAgAANHneLIAAAARAAgAANMbSRMAAAABABgAKIntAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEdyZWxsOgAxOTkzLnBkZgAADgASAAgAMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9HcmVsbC8xOTkzLnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1993)121%3C0764:PEOAUB%3E2.0.CO;2}} @article{arakawa_and_schubert_1974, Author = {Arakawa, A and Schubert, WH}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Date-Added = {2016-06-14 23:04:30 +0000}, Date-Modified = {2018-07-18 19:00:17 +0000}, Isi = {A1974S778800004}, @@ -2181,6 +2200,7 @@ @article{arakawa_and_schubert_1974 Title = {Interaction of a cumulus cloud ensemble with the large-scale environment, Part I}, Volume = {31}, Year = {1974}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQXJha2F3YS8xOTc0LnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAChtVQgxOTc0LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKG1ctM8h9AAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHQXJha2F3YQAAEAAIAADR53iyAAAAEQAIAAC0z4RkAAAAAQAYAChtVQAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBBcmFrYXdhOgAxOTc0LnBkZgAADgASAAgAMQA5ADcANAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9BcmFrYXdhLzE5NzQucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1974S778800004}} @article{harshvardhan_et_al_1989, @@ -2414,7 +2434,6 @@ @article{akmaev_1991 @article{siebesma_et_al_2007, Abstract = {A better conceptual understanding and more realistic parameterizations of convective boundary layers in climate and weather prediction models have been major challenges in meteorological research. In particular, parameterizations of the dry convective boundary layer, in spite of the absence of water phase-changes and its consequent simplicity as compared to moist convection, typically suffer from problems in attempting to represent realistically the boundary layer growth and what is often referred to as countergradient fluxes. The eddy-diffusivity (ED) approach has been relatively successful in representing some characteristics of neutral boundary layers and surface layers in general. The mass-flux (MF) approach, on the other hand, has been used for the parameterization of shallow and deep moist convection. In this paper, a new approach that relies on a combination of the ED and MF parameterizations (EDMF) is proposed for the dry convective boundary layer. It is shown that the EDMF approach follows naturally from a decomposition of the turbulent fluxes into 1) a part that includes strong organized updrafts, and 2) a remaining turbulent field. At the basis of the EDMF approach is the concept that nonlocal subgrid transport due to the strong updrafts is taken into account by the MF approach, while the remaining transport is taken into account by an ED closure. Large-eddy simulation (LES) results of the dry convective boundary layer are used to support the theoretical framework of this new approach and to determine the parameters of the EDMF model. The performance of the new formulation is evaluated against LES results, and it is shown that the EDMF closure is able to reproduce the main properties of dry convective boundary layers in a realistic manner. Furthermore, it will be shown that this approach has strong advantages over the more traditional countergradient approach, especially in the entrainment layer. As a result, this EDMF approach opens the way to parameterize the clear and cumulus-topped boundary layer in a simple and unified way.}, Author = {Siebesma, A. Pier and Soares, Pedro M. M. and Teixeira, Joao}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {DOI 10.1175/JAS3888.1}, @@ -2428,12 +2447,12 @@ @article{siebesma_et_al_2007 Title = {A combined eddy-diffusivity mass-flux approach for the convective boundary layer}, Volume = {64}, Year = {2007}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAqYEwIMjAwNy5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACphyMc7+4hQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAACFNpZWJlc21hABAACAAA0ed4sgAAABEACAAAxzxd+AAAAAEAGAAqYEwAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAU2llYmVzbWE6ADIwMDcucGRmAA4AEgAIADIAMAAwADcALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU2llYmVzbWEvMjAwNy5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000245742600011}} @article{soares_et_al_2004, Abstract = {Recently, a new consistent way of parametrizing simultaneously local and non-local turbulent transport for the convective atmospheric boundary layer has been proposed and tested for the clear boundary layer. This approach assumes that in the convective boundary layer the subgrid-scale fluxes result from two different mixing scales: small eddies, that are parametrized by an eddy-diffusivity approach, and thermals, which are represented by a mass-flux contribution. Since the interaction between the cloud layer and the underlying sub-cloud layer predominantly takes place through strong updraughts, this approach offers an interesting avenue of establishing a unified description of the turbulent transport in the cumulus-topped boundary layer. This paper explores the possibility of such a new approach for the cumulus-topped boundary layer. In the sub-cloud and cloud layers, the mass-flux term represents the effect of strong updraughts. These are modelled by a simple entraining parcel, which determines the mean properties of the strong updraughts, the boundary-layer height, the lifting condensation level and cloud top. The residual smaller-scale turbulent transport is parametrized with an eddy-diffusivity approach that uses a turbulent kinetic energy closure. The new scheme is implemented and tested in the research model MesoNH. Copyright {\copyright} 2004 Royal Meteorological Society}, Author = {Soares, P. M. M. and Miranda, P. M. A. and Siebesma, A. P. and Teixeira, J.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1256/qj.03.223}, @@ -2447,11 +2466,11 @@ @article{soares_et_al_2004 Url = {http://dx.doi.org/10.1256/qj.03.223}, Volume = {130}, Year = {2004}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBCLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmTxEBxgAAAAABxgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWIC2CDIwMDQucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABYf6DSsqNwAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAAZTb2FyZXMAEAAIAADR53iyAAAAEQAIAADSswXgAAAAAQAYAFiAtgAobJYAKGyLAChnewAbXgcAAphcAAIAXE1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBTb2FyZXM6ADIwMDQucGRmAA4AEgAIADIAMAAwADQALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAElVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvU29hcmVzLzIwMDQucGRmAAATAAEvAAAVAAIADf//AAAACAANABoAJABpAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjM=}, Bdsk-Url-1 = {http://dx.doi.org/10.1256/qj.03.223}} @article{troen_and_mahrt_1986, Author = {Troen, IB and Mahrt, L.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:17:49 +0000}, Date-Modified = {2016-05-20 17:17:49 +0000}, Doi = {10.1007/BF00122760}, @@ -2465,13 +2484,13 @@ @article{troen_and_mahrt_1986 Url = {http://dx.doi.org/10.1007/BF00122760}, Volume = {37}, Year = {1986}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvVHJvZW4vMTk4Ni5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAABNeegIMTk4Ni5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAE13kNKUWwUAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAABVRyb2VuAAAQAAgAANHneLIAAAARAAgAANKUvXUAAAABABgATXnoAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AFRyb2VuOgAxOTg2LnBkZgAADgASAAgAMQA5ADgANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Ucm9lbi8xOTg2LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://dx.doi.org/10.1007/BF00122760}} @article{macvean_and_mason_1990, Abstract = {Abstract In a recent paper, Kuo and Schubert demonstrated the lack of observational support for the relevance of the criterion for cloud-top entrainment instability proposed by Randall and by Deardorff. Here we derive a new criterion, based on a model of the instability as resulting from the energy released close to cloud top, by Mixing between saturated boundary-layer air and unsaturated air from above the capping inversion. The condition is derived by considering the net conversion from potential to kinetic energy in a system consisting of two layers of fluid straddling cloud-top, when a small amount of mixing occurs between these layers. This contrasts with previous analyses, which only considered the change in buoyancy of the cloud layer when unsaturated air is mixed into it. In its most general form, this new criterion depends on the ratio of the depths of the layers involved in the mixing. It is argued that, for a self-sustaining instability, there must be a net release of kinetic energy on the same depth and time scales as the entrainment process itself. There are two plausible ways in which this requirement may be satisfied. Either one takes the depths of the layers involved in the mixing to each be comparable to the vertical scale of the entrainment process, which is typically of order tens of meters or less, or alternatively, one must allow for the efficiency with which energy released by mixing through a much deeper lower layer becomes available to initiate further entrainment. In both cases the same criterion for instability results. This criterion is much more restrictive than that proposed by Randall and by Deardorff; furthermore, the observational data is then consistent with the predictions of the current theory. Further analysis provides estimates of the turbulent fluxes associated with cloud-top entrainment instability. This analysis effectively constitutes an energetically consistent turbulence closure for models of boundary layers with cloud. The implications for such numerical models are discussed. Comparisons are also made with other possible criteria for cloud-top entrainment instability which have recently been suggested.}, Annote = {doi: 10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Author = {MacVean, M. K. and Mason, P. J.}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Booktitle = {Journal of the Atmospheric Sciences}, Da = {1990/04/01}, Date-Added = {2016-05-20 17:16:05 +0000}, @@ -2490,11 +2509,11 @@ @article{macvean_and_mason_1990 Url = {http://dx.doi.org/10.1175/1520-0469(1990)047<1012:CTEITS>2.0.CO;2}, Volume = {47}, Year = {1990}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBDLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTWFjVmVhbi8xOTkwLnBkZk8RAcoAAAAAAcoAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAFx8zwgxOTkwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAXHyn0rkkRQAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAHTWFjVmVhbgAAEAAIAADR53iyAAAAEQAIAADSuYa1AAAAAQAYAFx8zwAobJYAKGyLAChnewAbXgcAAphcAAIAXU1hY2ludG9zaCBIRDpVc2VyczoAZ3JhbnRmOgBDbG91ZFN0YXRpb246AGZpcmxfbGlicmFyeToAZmlybF9saWJyYXJ5X2ZpbGVzOgBNYWNWZWFuOgAxOTkwLnBkZgAADgASAAgAMQA5ADkAMAAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9NYWNWZWFuLzE5OTAucGRmABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGoAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOA==}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0469(1990)047%3C1012:CTEITS%3E2.0.CO;2}} @article{louis_1979, Author = {Louis, JF}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Date-Added = {2016-05-20 17:15:52 +0000}, Date-Modified = {2016-05-20 17:15:52 +0000}, Isi = {A1979HT69700004}, @@ -2507,12 +2526,12 @@ @article{louis_1979 Title = {A PARAMETRIC MODEL OF VERTICAL EDDY FLUXES IN THE ATMOSPHERE}, Volume = {17}, Year = {1979}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBBLi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG91aXMvMTk3OS5wZGZPEQHEAAAAAAHEAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAonogIMTk3OS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACiej8FuU4pQREYgQ0FSTwACAAUAAAkgAAAAAAAAAAAAAAAAAAAABUxvdWlzAAAQAAgAANHneLIAAAARAAgAAMFutfoAAAABABgAKJ6IAChslgAobIsAKGd7ABteBwACmFwAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvdWlzOgAxOTc5LnBkZgAADgASAAgAMQA5ADcAOQAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIASFVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9Mb3Vpcy8xOTc5LnBkZgATAAEvAAAVAAIADf//AAAACAANABoAJABoAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAjA=}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1979HT69700004}} @article{lock_et_al_2000, Abstract = {A new boundary layer turbulent mixing scheme has been developed for use in the UKMO weather forecasting and climate prediction models. This includes a representation of nonlocal mixing (driven by both surface fluxes and cloud-top processes) in unstable layers, either coupled to or decoupled from the surface, and an explicit entrainment parameterization. The scheme is formulated in moist conserved variables so that it can treat both dry and cloudy layers. Details of the scheme and examples of its performance in single-column model tests are presented.}, Author = {Lock, AP and Brown, AR and Bush, MR and Martin, GM and Smith, RNB}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Date-Added = {2016-05-20 17:15:36 +0000}, Date-Modified = {2016-05-20 17:15:36 +0000}, Isi = {000089461100008}, @@ -2525,13 +2544,13 @@ @article{lock_et_al_2000 Title = {A new boundary layer mixing scheme. {P}art {I}: Scheme description and single-column model tests}, Volume = {128}, Year = {2000}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAACibewgyMDAwLnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAKJuLywPrPAAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAETG9jawAQAAgAANHneLIAAAARAAgAAMsETawAAAABABgAKJt7AChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AExvY2s6ADIwMDAucGRmAA4AEgAIADIAMAAwADAALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvTG9jay8yMDAwLnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/000089461100008}} @article{hong_and_pan_1996, Abstract = {Abstract In this paper, the incorporation of a simple atmospheric boundary layer diffusion scheme into the NCEP Medium-Range Forecast Model is described. A boundary layer diffusion package based on the Troen and Mahrt nonlocal diffusion concept has been tested for possible operational implementation. The results from this approach are compared with those from the local diffusion approach, which is the current operational scheme, and verified against FIFE observations during 9?10 August 1987. The comparisons between local and nonlocal approaches are extended to the forecast for a heavy rain case of 15?17 May 1995. The sensitivity of both the boundary layer development and the precipitation forecast to the tuning parameters in the nonlocal diffusion scheme is also investigated. Special attention is given to the interaction of boundary layer processes with precipitation physics. Some results of parallel runs during August 1995 are also presented.}, Annote = {doi: 10.1175/1520-0493(1996)124<2322:NBLVDI>2.0.CO;2}, Author = {Hong, Song-You and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Booktitle = {Monthly Weather Review}, Da = {1996/10/01}, Date = {1996/10/01}, @@ -2552,13 +2571,13 @@ @article{hong_and_pan_1996 Volume = {124}, Year = {1996}, Year1 = {1996}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBALi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZk8RAcAAAAAAAcAAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAANHnJFJIKwAAAE18FggxOTk2LnBkZgAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAATXvY0pRb8QAAAAAAAAAAAAIABQAACSAAAAAAAAAAAAAAAAAAAAAESG9uZwAQAAgAANHneLIAAAARAAgAANKUvmEAAAABABgATXwWAChslgAobIsAKGd7ABteBwACmFwAAgBaTWFjaW50b3NoIEhEOlVzZXJzOgBncmFudGY6AENsb3VkU3RhdGlvbjoAZmlybF9saWJyYXJ5OgBmaXJsX2xpYnJhcnlfZmlsZXM6AEhvbmc6ADE5OTYucGRmAA4AEgAIADEAOQA5ADYALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEdVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSG9uZy8xOTk2LnBkZgAAEwABLwAAFQACAA3//wAAAAgADQAaACQAZwAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIr}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/1520-0493(1996)124%3C2322:NBLVDI%3E2.0.CO;2}} @article{han_and_pan_2006, Abstract = {Abstract A parameterization of the convection-induced pressure gradient force (PGF) in convective momentum transport (CMT) is tested for hurricane intensity forecasting using NCEP's operational Global Forecast System (GFS) and its nested Regional Spectral Model (RSM). In the parameterization the PGF is assumed to be proportional to the product of the cloud mass flux and vertical wind shear. Compared to control forecasts using the present operational GFS and RSM where the PGF effect in CMT is taken into account empirically, the new PGF parameterization helps increase hurricane intensity by reducing the vertical momentum exchange, giving rise to a closer comparison to the observations. In addition, the new PGF parameterization forecasts not only show more realistically organized precipitation patterns with enhanced hurricane intensity but also reduce the forecast track error. Nevertheless, the model forecasts with the new PGF parameterization still largely underpredict the observed intensity. One of the many possible reasons for the large underprediction may be the absence of hurricane initialization in the models.}, Annote = {doi: 10.1175/MWR3090.1}, Author = {Han, Jongil and Pan, Hua-Lu}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Booktitle = {Monthly Weather Review}, Da = {2006/02/01}, Date-Added = {2016-05-20 17:11:17 +0000}, @@ -2577,11 +2596,11 @@ @article{han_and_pan_2006 Url = {http://dx.doi.org/10.1175/MWR3090.1}, Volume = {134}, Year = {2006}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxA/Li4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvSGFuLzIwMDYucGRmTxEBvgAAAAABvgACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAA0eckUkgrAAAAWsT5CDIwMDYucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABazFjStCvVAAAAAAAAAAAAAgAFAAAJIAAAAAAAAAAAAAAAAAAAAANIYW4AABAACAAA0ed4sgAAABEACAAA0rSORQAAAAEAGABaxPkAKGyWAChsiwAoZ3sAG14HAAKYXAACAFlNYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoASGFuOgAyMDA2LnBkZgAADgASAAgAMgAwADAANgAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIARlVzZXJzL2dyYW50Zi9DbG91ZFN0YXRpb24vZmlybF9saWJyYXJ5L2ZpcmxfbGlicmFyeV9maWxlcy9IYW4vMjAwNi5wZGYAEwABLwAAFQACAA3//wAAAAgADQAaACQAZgAAAAAAAAIBAAAAAAAAAAUAAAAAAAAAAAAAAAAAAAIo}, Bdsk-Url-1 = {http://dx.doi.org/10.1175/MWR3090.1}} @article{businger_et_al_1971, Author = {Businger, JA and Wyngaard, JC and Izumi, Y and Bradley, EF}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Date-Added = {2016-05-20 17:10:50 +0000}, Date-Modified = {2018-07-18 18:58:08 +0000}, Isi = {A1971I822800004}, @@ -2594,6 +2613,7 @@ @article{businger_et_al_1971 Title = {Flux-profile relationships in the atmospheric surface layer}, Volume = {28}, Year = {1971}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxBELi4vLi4vQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGZPEQHMAAAAAAHMAAIAAAxNYWNpbnRvc2ggSEQAAAAAAAAAAAAAAAAAAADR5yRSSCsAAAAodUUIMTk3MS5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACh1cbTPIxwAAAAAAAAAAAACAAUAAAkgAAAAAAAAAAAAAAAAAAAACEJ1c2luZ2VyABAACAAA0ed4sgAAABEACAAAtM+FjAAAAAEAGAAodUUAKGyWAChsiwAoZ3sAG14HAAKYXAACAF5NYWNpbnRvc2ggSEQ6VXNlcnM6AGdyYW50ZjoAQ2xvdWRTdGF0aW9uOgBmaXJsX2xpYnJhcnk6AGZpcmxfbGlicmFyeV9maWxlczoAQnVzaW5nZXI6ADE5NzEucGRmAA4AEgAIADEAOQA3ADEALgBwAGQAZgAPABoADABNAGEAYwBpAG4AdABvAHMAaAAgAEgARAASAEtVc2Vycy9ncmFudGYvQ2xvdWRTdGF0aW9uL2ZpcmxfbGlicmFyeS9maXJsX2xpYnJhcnlfZmlsZXMvQnVzaW5nZXIvMTk3MS5wZGYAABMAAS8AABUAAgAN//8AAAAIAA0AGgAkAGsAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACOw==}, Bdsk-Url-1 = {http://ws.isiknowledge.com/cps/openurl/service?url_ver=Z39.88-2004&rft_id=info:ut/A1971I822800004}} @article{xu_and_randall_1996, @@ -2784,18 +2804,17 @@ @article{kim_and_arakawa_1995 @techreport{hou_et_al_2002, Author = {Y. Hou and S. Moorthi and K. Campana}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}, Date-Added = {2016-05-19 19:52:22 +0000}, Date-Modified = {2016-05-20 15:14:59 +0000}, Institution = {NCEP}, Number = {441}, Title = {Parameterization of Solar Radiation Transfer}, Type = {office note}, - Year = {2002}} + Year = {2002}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAiLi4vLi4vemhhbmctbGliL2hvdV9ldF9hbF8yMDAyLnBkZk8RAdwAAAAAAdwAAgAADE1hY2ludG9zaCBIRAAAAAAAAAAAAAAAAAAAAM/T1mZIKwAAAFKkjRJob3VfZXRfYWxfMjAwMi5wZGYAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAUqai02OGCgAAAAAAAAAAAAIAAgAACSAAAAAAAAAAAAAAAAAAAAAJemhhbmctbGliAAAQAAgAAM/UKsYAAAARAAgAANNj2moAAAABABgAUqSNAE1lSgAj19QACTbFAAk2xAACZvkAAgBbTWFjaW50b3NoIEhEOlVzZXJzOgBtYW56aGFuZzoARG9jdW1lbnRzOgBNYW4uWmhhbmc6AGdtdGItZG9jOgB6aGFuZy1saWI6AGhvdV9ldF9hbF8yMDAyLnBkZgAADgAmABIAaABvAHUAXwBlAHQAXwBhAGwAXwAyADAAMAAyAC4AcABkAGYADwAaAAwATQBhAGMAaQBuAHQAbwBzAGgAIABIAEQAEgBIVXNlcnMvbWFuemhhbmcvRG9jdW1lbnRzL01hbi5aaGFuZy9nbXRiLWRvYy96aGFuZy1saWIvaG91X2V0X2FsXzIwMDIucGRmABMAAS8AABUAAgAP//8AAAAIAA0AGgAkAEkAAAAAAAACAQAAAAAAAAAFAAAAAAAAAAAAAAAAAAACKQ==}} @article{hu_and_stamnes_1993, Author = {Y.X. Hu and K. Stamnes}, - Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}, Date-Added = {2016-05-19 19:31:56 +0000}, Date-Modified = {2016-05-20 15:13:12 +0000}, Journal = {J. Climate}, @@ -2803,4 +2822,5 @@ @article{hu_and_stamnes_1993 Pages = {728-742}, Title = {An accurate parameterization of the radiative properties of water clouds suitable for use in climate models}, Volume = {6}, - Year = {1993}} + Year = {1993}, + Bdsk-File-1 = {YnBsaXN0MDDSAQIDBFxyZWxhdGl2ZVBhdGhZYWxpYXNEYXRhXxAnLi4vLi4vemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmTxEB8AAAAAAB8AACAAAMTWFjaW50b3NoIEhEAAAAAAAAAAAAAAAAAAAAz9PWZkgrAAAAUqSNF2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAABSpJHTY3R+AAAAAAAAAAAAAgACAAAJIAAAAAAAAAAAAAAAAAAAAAl6aGFuZy1saWIAABAACAAAz9QqxgAAABEACAAA02PI3gAAAAEAGABSpI0ATWVKACPX1AAJNsUACTbEAAJm+QACAGBNYWNpbnRvc2ggSEQ6VXNlcnM6AG1hbnpoYW5nOgBEb2N1bWVudHM6AE1hbi5aaGFuZzoAZ210Yi1kb2M6AHpoYW5nLWxpYjoAaHVfYW5kX3N0YW1uZXNfMTk5My5wZGYADgAwABcAaAB1AF8AYQBuAGQAXwBzAHQAYQBtAG4AZQBzAF8AMQA5ADkAMwAuAHAAZABmAA8AGgAMAE0AYQBjAGkAbgB0AG8AcwBoACAASABEABIATVVzZXJzL21hbnpoYW5nL0RvY3VtZW50cy9NYW4uWmhhbmcvZ210Yi1kb2MvemhhbmctbGliL2h1X2FuZF9zdGFtbmVzXzE5OTMucGRmAAATAAEvAAAVAAIAD///AAAACAANABoAJABOAAAAAAAAAgEAAAAAAAAABQAAAAAAAAAAAAAAAAAAAkI=}} diff --git a/physics/docs/pdftxt/CPT_CSAW.txt b/physics/docs/pdftxt/CPT_CSAW.txt index b7e178f82..723e65b20 100644 --- a/physics/docs/pdftxt/CPT_CSAW.txt +++ b/physics/docs/pdftxt/CPT_CSAW.txt @@ -1,5 +1,5 @@ /** -\page CSAW_scheme Scale-Aware Chikira-Sugiyama Scale-aware Convection Scheme with Arakawa-Wu Extension +\page CSAW_scheme Chikira-Sugiyama Scale-Aware Convection Scheme with Arakawa-Wu Extension \section cs_descrip Description The Chikira-Sugiyama cumulus scheme (Chikira and Sugiyama (2010) \cite Chikira_2010) with prognostic closure and diff --git a/physics/docs/pdftxt/CPT_MG3.txt b/physics/docs/pdftxt/CPT_MG3.txt index c6d169dc1..3dc3fece4 100644 --- a/physics/docs/pdftxt/CPT_MG3.txt +++ b/physics/docs/pdftxt/CPT_MG3.txt @@ -12,7 +12,7 @@ and number concentration of five hydrometeors (cloud water, cloud ice, rain, sno - MG2: Gettelman and Morrison (2015) \cite Gettelman_2015_1 \cite Gettelman_2015_2 (CESM2, CAM6) - Prognostic precipitation (rain and snow) - Sub-stepping and sub-column capable -- MG3: Gettelman et al. 2019 \cite Gettelman_et_al_2019 +- MG3: Gettelman et al. (2019) \cite Gettelman_et_al_2019 - Rimed hydrometeors (graupel or hail) are added to stratiform cloud scheme for global models - Global climate impacts are limited to small increased in ice mass - High (14 km) resolution simulations show local production of rimed ice (graupel) can affect regional diff --git a/physics/docs/pdftxt/CPT_adv_suite.txt b/physics/docs/pdftxt/CPT_adv_suite.txt index 53887139f..bca25db96 100644 --- a/physics/docs/pdftxt/CPT_adv_suite.txt +++ b/physics/docs/pdftxt/CPT_adv_suite.txt @@ -1,10 +1,9 @@ /** -\page MGCSAW_page MGCSAW +\page MGCSAW_page MGCSAW Suite \section MGCSAW_suite_overview Overview The advanced MGCSAW physics suite uses the parameterizations in the following order: - - \ref fast_sat_adj - \ref GFS_RRTMG - \ref GFS_SFCLYR - \ref GFS_NSST @@ -21,11 +20,10 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or - \ref CPT_MG3 - \ref mod_cs_conv_aw_adj - \ref GFS_CALPRECIPTYPE - - \ref STOCHY_PHYS \section sdf_cpt_suite Suite Definition File -The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c suite_SCM_MGCSAW.xml : +The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c SCM_MGCSAW : \code diff --git a/physics/docs/pdftxt/GFDL_cloud.txt b/physics/docs/pdftxt/GFDL_cloud.txt index c3933f156..414d41374 100644 --- a/physics/docs/pdftxt/GFDL_cloud.txt +++ b/physics/docs/pdftxt/GFDL_cloud.txt @@ -4,8 +4,8 @@ GFDL cloud microphysics (MP) scheme is a six-category MP scheme to replace Zhao-Carr MP scheme, and moves the GFS from a total cloud water variable to five predicted hydrometeors (cloud water, cloud ice, rain, snow and graupel). This scheme utilizes the "bulk water" microphysical parameterization technique in Lin et al. (1983) \cite lin_et_al_1983 -and has been significantly improved over years at GFDL (Lord et al.(1984) \cite lord_et_al_1984, -Krueger et al.(1995) \cite krueger_et_al_1995, Chen and Lin (2011) \cite chen_and_lin_2011, Chen and Lin (2013) \cite chen_and_lin_2013). +and has been significantly improved over years at GFDL (Lord et al. (1984) \cite lord_et_al_1984, +Krueger et al. (1995) \cite krueger_et_al_1995, Chen and Lin (2011) \cite chen_and_lin_2011, Chen and Lin (2013) \cite chen_and_lin_2013). Physics processes of GFDL cloud MP are described in Figure 1 (also see warm_rain() and icloud()) and are feature with time-split between warm-rain (faster) and ice-phase (slower) processes (see 'conversion time scale' in gfdl_cloud_microphys.F90 for default values). \image html gfdl_cloud_mp_diagram.png "Figure 1: GFDL MP at a glance (Courtesy of S.J. Lin at GFDL)" width=10cm @@ -43,7 +43,7 @@ h_{var}=\min \left\{0.2,\max\left[0.01, D_{ocean}(\frac{A_{r}}{10^{10}})^{0.25}\ Where \f$A_{r}\f$ is cell area, \f$D_{land}\f$ and \f$D_{ocean}\f$ are base values for sub-grid variability over land and ocean (larger sub-grid variability appears in larger area). Horizontal sub-grid variability is used in cloud fraction, relative humidity calculation, evaporation and condensation processes. Scale-awareness is achieved by this horizontal subgrid variability and a \f$2^{nd}\f$ -order FV-type vertical reconstruction (Lin et al.(1994) \cite lin_et_al_1994). +order FV-type vertical reconstruction (Lin et al. (1994) \cite lin_et_al_1994). \section nml_opt Namelist Option \ref gfdl_cloud_microphysics_nml diff --git a/physics/docs/pdftxt/GFS_GWDC.txt b/physics/docs/pdftxt/GFS_GWDC.txt index 53e9cc1cb..c8fb70afa 100644 --- a/physics/docs/pdftxt/GFS_GWDC.txt +++ b/physics/docs/pdftxt/GFS_GWDC.txt @@ -13,7 +13,7 @@ The importance of convectively-generated tropical waves in driving the equatorial stratospheric semi-annual oscillation (SAO) and quasi-biennial oscillation (QBO) has been appreciated for many years. - In a review paper on gravity waves in the middle atmosphere, Fritts(1984) \cite fritts_1984 + In a review paper on gravity waves in the middle atmosphere, Fritts (1984) \cite fritts_1984 showed that a large portion of observed gravity wave momentum flux has higher frequencies than those of stationary mountain waves. This phenomenon was explained by cumulus @@ -22,7 +22,7 @@ wind and stability are weak, the magnitude of the surface drag and the resultant influence of orographically-induced gravity wave drag on the large-scale flow are relatively small compared with those in - wintertime (Palmer et al.(1986) \cite palmer_et_al_1986). In this + wintertime (Palmer et al. (1986) \cite palmer_et_al_1986). In this situation, the relative importance of cumulus convection as a source of gravity waves is larger. In addition, in the tropical regions where persistent convection exists, deep cumulus clouds impinging on @@ -34,7 +34,7 @@ Compared with orographic gravitity waves, it has proven more difficult to model the way in which gravity waves are generated by various convective sources; The simplest situation is depicted in Figure 1. There are several proposed generation mechanisms in the literature (see section 3b in - Kim et al.(2003) \cite kim_et_al_2003). Amongst, Chun and Baik (1998) \cite chun_and_baik_1998 + Kim et al. (2003) \cite kim_et_al_2003). Amongst, Chun and Baik (1998) \cite chun_and_baik_1998 proposed a way for parameterizing convection-induced subgrid-scale gravity wave momentum flux in large-scale models. For the momentum flux profile up to the cloud-top height, use of the linear diff --git a/physics/docs/pdftxt/GFS_H2OPHYS.txt b/physics/docs/pdftxt/GFS_H2OPHYS.txt index ca3cd2041..efd38065f 100644 --- a/physics/docs/pdftxt/GFS_H2OPHYS.txt +++ b/physics/docs/pdftxt/GFS_H2OPHYS.txt @@ -3,7 +3,7 @@ \section des_h2o Description To improve the treatment of stratospheric water vapor in the global model, NCEP implemented a parameterization of photochemical production and loss (P-L) of water vapor through methane oxidation and photolysis of H2O in the upper mesosphere due to solar Lyman alpha absorption is implemented in GFS. -The Navy Research Laboratory (NRL) linearized parameterization of stratospheric and mesospheric water vapor photochemistry (McCormack at al.(2008) +The Navy Research Laboratory (NRL) linearized parameterization of stratospheric and mesospheric water vapor photochemistry (McCormack at al. (2008) \cite mccormack_et_al_2008) applies a linearized photochemical tendency to specific humidity q in the form \f[ \frac{dq}{dt}=(P-L)_{0}+\frac{\partial (P-L)}{\partial q}\mid_{0}(q-q_{0}) diff --git a/physics/docs/pdftxt/GFS_NOAH.txt b/physics/docs/pdftxt/GFS_NOAH.txt index d6928b38a..19360d092 100644 --- a/physics/docs/pdftxt/GFS_NOAH.txt +++ b/physics/docs/pdftxt/GFS_NOAH.txt @@ -7,26 +7,26 @@ predictability on daily to seasonal timescale (Betts et al. (2017) \cite betts_et_al_2017), but also in terms of influencing extremes such as drought and heatwaves (Paimazumder and Done (2016) \cite paimazumder_and_done_2016), PBL evolution and cloud - formation (Milovac et al.(2016) \cite milovac_et_al_2016) and afternoon + formation (Milovac et al. (2016) \cite milovac_et_al_2016) and afternoon convection (Guillod et al. (2015) \cite guillod_et_al_2015), and tropical cyclone re-intensification (Andersen and Shepherd (2014) \cite andersen_and_shepherd_2014). Other linkages, such as the role of soil moisture (SM) or vegetation heterogeneity in mesoscale circulation - (Hsu et al.(2017) \cite hsu_et_al_2017) and planetary waves (Koster et al.(2014) \cite koster_et_al_2014), + (Hsu et al. (2017) \cite hsu_et_al_2017) and planetary waves (Koster et al. (2014) \cite koster_et_al_2014), and those driven by land use and land cover change or management (Hirsch et al. (2015) \cite hirsch_et_al_2015; - Findell et al.(2017) \cite findell_et_al_2017) are topics of active research. + Findell et al. (2017) \cite findell_et_al_2017) are topics of active research. Figure 1 is a schematic of local land-atmosphere interactions in a quiescent synoptic regime, including the soil moisture-precipitation - (SM-P) feedback pathways. Solid arrows indicate a positive feedback + (SM-P) feedback pathways (Ek and Mahrt (1994) \cite ek_and_mahrt_1994; Ek and Holtslag (2004) \cite ek_and_holtslag_2004 ). Solid arrows indicate a positive feedback pathway, and large dashed arrows represent a negative feedback, while red indicates radiative, black indicates surface layer and PBL, and brown indicates land surface processes. Thin red and grey dashed lines with arrows also represent positive feedbacks. The single horizontal gay-dotted line (no arrows) indicates the top of the PBL, and the seven small vertical dashed lines (no arrows) represent precipitation - \image html Noah_LA_interaction.png "Figure 1: Local Land-atmosphere Interaction (courtesy of Michael Ek, Ek and Mahrt (1994), Ek and Holtslag (2004))" width=10cm + \image html Noah_LA_interaction.png "Figure 1: Local Land-atmosphere Interaction (courtesy of Michael Ek)" width=10cm Recently, the land surface updates in 2017 GFS operational physics includes: - IGBP 20-type 1-km land classification - STASGO 19-type 1-km soil classification diff --git a/physics/docs/pdftxt/GFS_SFCLYR.txt b/physics/docs/pdftxt/GFS_SFCLYR.txt index 6ed7ed3c2..60d804a01 100644 --- a/physics/docs/pdftxt/GFS_SFCLYR.txt +++ b/physics/docs/pdftxt/GFS_SFCLYR.txt @@ -12,7 +12,7 @@ in the very stable and very unstable situations. \ref Noah_LSM are largely responsible for the quality of model forecasts produced for near-surface weather parameters, such as 2-meter air temperature (\f$T_{2m}\f$) and surface skin temperature - (\f$LST\f$). \f$LST\f$ is derived from the surface energy budget, and is + (\f$LST\f$). \f$LST\f$ is derived from the surface energy budget, and is particularly important to remote sensing and data assimilation. How precise these two parameters can be simulated by the model strongly depends on how accurate the surface heat fluxes are parameterized, @@ -31,10 +31,10 @@ in the very stable and very unstable situations. In May 2011, the new vegetation-dependent formulations of thermal roughness formulation ( - Zheng et al.(2012) \cite zheng_et_al_2012) + Zheng et al. (2012) \cite zheng_et_al_2012) was implemented to deal with the cold \f$LST\f$ bias over the arid western continental United States - (CONUS) during daytime. The thermal roughness length \f$Z_{0H}\f$ is derived by a + (CONUS) during daytime. The thermal roughness length \f$Z_{0H}\f$ is derived by a seasonlly varying formulation dependent on the seasonal cycle of green vegetation fraction. In this \f$Z_{0H}\f$ formulation, a key parameter known as \f$C_{zil}\f$ is specified according to a dependence on canopy height. @@ -43,7 +43,7 @@ The NCEP GFS global prediction model has experienced a longstanding problem of s cold bias in the \f$T_{2m}\f$ forecasts over land in the late afternoon and nighttime during moist seasons. This cold bias is closely associated with the nocturnal stable boundary layer and is accompanied by a corresponding warm air temperature bias in the first -model level above the ground. In 2017, Zheng et al.(2017) \cite zheng_et_al_2017 identified the +model level above the ground. In 2017, Zheng et al. (2017) \cite zheng_et_al_2017 identified the bias and introduced a stability parameter constraint \f$(z/L)_{lim}\f$ to prevent the land-atmosphere system from fully decoupling: \f[ (z/L)_{lim}=\frac{ln(\frac{z}{z_{0M}})}{2\alpha(1-\frac{z_{0M}}{z})} @@ -51,11 +51,11 @@ bias and introduced a stability parameter constraint \f$(z/L)_{lim}\f$ to preven Here \f$z\f$ is the height, \f$L\f$ is the Obukhov length, \f$z_{0M}\f$ is the momentum roughness length, and \f$\alpha = 5\f$. -The pertinent features of the GFS stable surface layer parameterization scheme are described in the appendix of Zheng et al.(2017) +The pertinent features of the GFS stable surface layer parameterization scheme are described in the appendix of Zheng et al. (2017) \cite zheng_et_al_2017. \section intra_rough Intraphysics Communication -\ref arg_table_sfc_ex_coef_run +\ref arg_table_sfc_diff_run \section gen_rough General Algorithm \ref general_diff diff --git a/physics/docs/pdftxt/GFS_SFCSICE.txt b/physics/docs/pdftxt/GFS_SFCSICE.txt index 8f39c5eef..b7b3c38f3 100644 --- a/physics/docs/pdftxt/GFS_SFCSICE.txt +++ b/physics/docs/pdftxt/GFS_SFCSICE.txt @@ -25,13 +25,13 @@ A sea ice model, in general, may contain subcomponents treating 1) dynamics (ice motion), 2) ice transport, 3) multiple ice thickness categories (including leads), 4) surface albedo, and 5) vertical thermodynamics. GFS sea ice scheme is concerned with a scheme for the - last of these processes. A three-layer thermodynamic sea ice model (Winton(2000) \cite winton_2000) + last of these processes. A three-layer thermodynamic sea ice model (Winton (2000) \cite winton_2000) has been coupled to GFS. It predicts sea ice/snow thickness, the surface temperature and ice temperature structure. In each model grid box, the heat and moisture fluxes and albedo are treated separately for the ice and the open water. \section intra_sice Intraphysics Communication -+ GFS Sea Ice Driver(\ref arg_table_sfc_sice_run) ++ GFS Sea Ice Driver (\ref arg_table_sfc_sice_run) + Three-layer Thermodynamics Sea Ice Model (ice3lay()) \cite winton_2000 \section gen_sice General Algorithm diff --git a/physics/docs/pdftxt/GFS_SURFACE_PERT.txt b/physics/docs/pdftxt/GFS_SURFACE_PERT.txt index 480946b57..1ecdfaa34 100644 --- a/physics/docs/pdftxt/GFS_SURFACE_PERT.txt +++ b/physics/docs/pdftxt/GFS_SURFACE_PERT.txt @@ -1,16 +1,28 @@ /** \page surf_pert GFS Surface Parameter Perturbation \section des_sfcpert Description -Parameterizations of physical process include a number of tunable -Land surface perturbation (Gehne et al.(2019) \cite Gehne_2019) has been recently introduced +Land surface perturbation (Gehne et al. (2019) \cite Gehne_2019) has been recently introduced into FV3GFS. This treatment is based on the hypothesis that one of the major causes of the insufficient spread in current global NWP model,especially near the surface, is a lack of treatment of uncertainty in the soil state and in the associated model parameters. It allows for land surface parameters such as surface albedo, -vegetation fraction,soil hydraulic conductivity,leaf area index (LAI),surface roughness lengths for heat and momentom to vary in space. -These parameters and variables have been shown to impact forecasts of 2m temperature,10m wind and precipitation.Based on the parameter +vegetation fraction, soil hydraulic conductivity, leaf area index (LAI), surface roughness lengths for heat and momentom to vary in space. +These parameters and variables have been shown to impact forecasts of 2m temperature, 10m wind and precipitation. Based on the parameter or variable,different strategies to perturb are necessary. +Table 1 presents a summary of the uncertainty or range of values associated with the parameters and variables that are considered. + +\section table Uncertainty or range of values identified for the perturbed parameters (Gehne et al. (2019)) +| Parameter or variable | Estimated uncertainty or range | Reference | +|-----------------------------------|---------------------------------------|------------------------------------| +| Albedo | 2\%-12\% of Albedo | Grant et al. (2000) \cite grant_et_al_2000 ; Qu and Hall (2005) \cite qu_and_hall_2005 | +| Vegetation fraction | 20\%-30\% of Vegetation fraction | Computed from MODIS vegetation fraction data | +| Momentum roughness length + + + + + Momentum roughness length (\f$Z_{0}\f$),heat/momentum roughness length ratio (\f$Z_{t}/Z_{0}\f$), Albedo and vegetation fraction perturbation are applied by percentile matching of the normal distribution with the beta distribution diff --git a/physics/docs/pdftxt/GFSv15_suite.txt b/physics/docs/pdftxt/GFSv15_suite.txt index ca931d614..306213a7f 100644 --- a/physics/docs/pdftxt/GFSv15_suite.txt +++ b/physics/docs/pdftxt/GFSv15_suite.txt @@ -1,22 +1,20 @@ /** -\page GFS_v15_page GFS_v15 +\page GFS_v15_page GFS_v15 Suite \section gfs1_suite_overview Overview -Effective on or about Wednesday, June 12, 2019, beginning with the 1200 -Coordinated Universal Time (UTC) run, the National Centers for Environmental -Prediction (NCEP) will upgrade the Global Forecast Systems (GFS) from version 14 to 15. - -GFS v15 will use the Finite-Volume Cubed-Sphere (FV3) dynamical core +Version 15 of the Global Forecast System (GFS) was implemented operationally by the NOAA +National Centers for Environmental Prediction (NCEP) on June 12, 2019. +GFS v15 uses the Finite-Volume Cubed-Sphere (FV3) dynamical core and a revised physics suite when compared to GFS v14. + - Replacement of the Zhao-Carr microphysics with the more advanced \ref GFDL_cloud - Updated parameterization of ozone photochemistry with additional production and loss terms -- Newly introduced parameterization of middle atmospheric water vapor photochemistry (\ref GFS_H2OPHYS) +- Newly introduced parameterization of middle atmospheric water vapor photochemistry - Revised bare soil evaporation scheme - Modified convective parameterization scheme to reduce excessive cloud top cooling -The GFSv15 physics suite uses the parameterizations in the following order: - - \ref fast_sat_adj +The GFS v15 physics suite uses the parameterizations in the following order: - \ref GFS_RRTMG - \ref GFS_SFCLYR - \ref GFS_NSST @@ -32,11 +30,10 @@ The GFSv15 physics suite uses the parameterizations in the following order: - \ref GFS_SAMFshal - \ref GFDL_cloud - \ref GFS_CALPRECIPTYPE - - \ref STOCHY_PHYS \section sdf_gfsv15 Suite Definition File -The GFSv15 suite uses the parameterizations in the following order, as defined in \c suite_SCM_GFS_v15.xml: +The GFS v15 suite uses the parameterizations in the following order, as defined in \c SCM_GFS_v15: \code diff --git a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt index dab159d71..6acbf03ab 100644 --- a/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt +++ b/physics/docs/pdftxt/GFSv15_suite_TKEEDMF.txt @@ -1,11 +1,10 @@ /** -\page GFS_v15plus_page GFS_v15plus +\page GFS_v15plus_page GFS_v15plus Suite \section gfs2p_suite_overview Overview -This physics suite is the same as GFSv15 physics suite with \ref GFS_SATMEDMF replace of \ref GFS_HEDMF . +This physics suite is the same as GFS v15 physics suite with \ref GFS_SATMEDMF replace of \ref GFS_HEDMF . - - \ref fast_sat_adj - \ref GFS_RRTMG - \ref GFS_SFCLYR - \ref GFS_NSST @@ -21,12 +20,11 @@ This physics suite is the same as GFSv15 physics suite with \ref GFS_SATMEDMF r - \ref GFS_SAMFshal - \ref GFDL_cloud - \ref GFS_CALPRECIPTYPE - - \ref STOCHY_PHYS \section sdf_gfsv15p Suite Definition File -The GFSv15plus suite uses the parameterizations in the following order, as defined in \c suite_SCM_GFS_v15plus.xml : +The GFS v15plus suite uses the parameterizations in the following order, as defined in \c SCM_GFS_v15plus : \code diff --git a/physics/docs/pdftxt/GSD_CU_GF_deep.txt b/physics/docs/pdftxt/GSD_CU_GF_deep.txt index 6d97a716c..041e92692 100644 --- a/physics/docs/pdftxt/GSD_CU_GF_deep.txt +++ b/physics/docs/pdftxt/GSD_CU_GF_deep.txt @@ -1,25 +1,22 @@ /** -\page GSD_CU_GF GSD Grell-Freitas Scale and Aerosol Aware Convection Scheme +\page GSD_CU_GF Grell-Freitas Scale and Aerosol Aware Convection Scheme \section gfcu_descrip Description -The Rapid Refresh (RAP) uses the Grell-Freitas (GF) convective scheme, while the HRRR allows direct prediction -of convection at its 3-km horizontal scale. In the RAP, the Grell-Freitas parameterization removes convective -instability so that the gridscale precipitation scheme does not "convect", convective precipitation is a scheme -byproduct. Grell-Freitas is an Arakawa-Schubert mass flux type scheme, and is both aerosol and model scale aware. +The Grell-Freitas scale and aerosol aware convection scheme is an Arakawa-Schubert mass flux type scheme, and is both aerosol and scale aware. Aerosol awareness (emulating the impact of aerosols on precipitation processes) is obtained through changing the rate of -converstion from cloud droplets to raindrops (Berry 1968 \cite berry_1968 ), and by modifying the precipitation efficiency of the -raindrops (the fraction of total condensed water volume in the cloud's lifetime reaching the ground (Jiang et al.(2010) \cite Jiang_2010) ) +conversion from cloud droplets to raindrops (Berry (1968) \cite berry_1968 ), and by modifying the precipitation efficiency of the +raindrops (the fraction of total condensed water volume in the cloud's lifetime reaching the ground (Jiang et al. (2010) \cite Jiang_2010) ) Scale awareness comes through the use of an empirical formula for the fractional area (\f$\sigma\f$) of the model grid column containing updrafts and downdrafts (Arakawa et al. (2011) \cite Arakawa_2011 ). The entrainment rate for the updrafts is an inverse function -of \f$\sigma\f$. As the fractional coverage become large, the resolved motion takes over convective processes (why the HRRR is called -"convection allowing") and the Grell-Freitas scheme becomes a shallow convection scheme, simulating the effects of unresolved fair weather +of \f$\sigma\f$. As the fractional coverage become large, the resolved motion takes over convective processes +and the Grell-Freitas scheme becomes a shallow convection scheme, simulating the effects of unresolved fair weather and towering cumulus on the forecast variables. -The GF scheme still uses an ensemble of convective schemes, but is now limited to options that modulate closure and capping +The GF scheme uses an ensemble of convective schemes, with options that modulate closure and capping inversion thresholds for convection. After calculations for each member of the cloud ensemble in the convective scheme, the ensemble mean time tendency for temperature, moisture, and cloud and precipitation hydrometeors is passed to the rest of the model -(Grell and \f$D\acute{e}v\acute{e}nyi\f$, 2002 \cite Grell_2002 ). Additionally, the upward mass flux from parameterized convective updrafts is balanced by -subsidence in adjacent grid columns, if horizontal resolution of the model using the parameterization is less than 10 km. +(Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 ). Additionally, the upward mass flux from parameterized convective updrafts is balanced by +subsidence in adjacent grid columns, if the horizontal grid spacing of the model using the parameterization is less than 10 km. # Operational Impacts in RAP/HRRR diff --git a/physics/docs/pdftxt/GSD_THOMPSON.txt b/physics/docs/pdftxt/GSD_THOMPSON.txt index 2598d3174..525d3bedc 100644 --- a/physics/docs/pdftxt/GSD_THOMPSON.txt +++ b/physics/docs/pdftxt/GSD_THOMPSON.txt @@ -1,5 +1,5 @@ /** -\page GSD_THOMPSON Aerosol-Aware Thompson Microphysics Scheme +\page GSD_THOMPSON Thompson Aerosol-Aware Microphysics Scheme \section thompson_descrp Description diff --git a/physics/docs/pdftxt/GSD_adv_suite.txt b/physics/docs/pdftxt/GSD_adv_suite.txt index 16de26c63..0db91ede1 100644 --- a/physics/docs/pdftxt/GSD_adv_suite.txt +++ b/physics/docs/pdftxt/GSD_adv_suite.txt @@ -1,10 +1,8 @@ /** -\page GSD_v0_page GSD_v0 +\page GSD_v0_page GSD_v0 Suite \section gsd_suite_overview Overview -# History of RUC, RAP/HRRR model development at NOAA/GSD - The original Rapid Update Cycle (RUC), implemented in 1994, was designed to provide accurate short-range (0 to 12-hr) numerical forecast guidance for weather-sensitive users, including those in the U.S. aviation community. The RUC started to run every hour starting in 1998. Significant weather forecasting problems that occur in the 0- to @@ -36,11 +34,10 @@ The advanced GSD RAP/HRRR physics suite uses the parameterizations in the follow - \ref GFS_GWDC - \ref GSD_THOMPSON - \ref GFS_CALPRECIPTYPE - - \ref STOCHY_PHYS \section sdf_gsdsuite Suite Definition File -The GSD RAP/HRRR physics suite uses the parameterizations in the following order, as defined in \c suite_SCM_GSD_v0.xml : +The GSD RAP/HRRR physics suite uses the parameterizations in the following order, as defined in \c SCM_GSD_v0: \code diff --git a/physics/docs/pdftxt/all_shemes_list.txt b/physics/docs/pdftxt/all_shemes_list.txt index 3d57b41ea..39b4917ef 100644 --- a/physics/docs/pdftxt/all_shemes_list.txt +++ b/physics/docs/pdftxt/all_shemes_list.txt @@ -8,20 +8,19 @@ In the CCPP-Physics v3.0 release, each parameterization is in its own modern For code maintenance. While some individual parameterization can be invoked for the GMTB SCM, most users will assemble the parameterizations in suites. -- Radiation: +- \b Radiation - \subpage GFS_RRTMG -- PBL and Turbulence: +- \b PBL \b and \b Turbulence - \subpage GFS_HEDMF - \subpage GFS_SATMEDMF - \subpage GSD_MYNNEDMF -- Land Surface Model: +- \b Land \b Surface \b Model - \subpage GFS_NOAH - - \subpage surf_pert - \subpage GSD_RUCLSM -- Cumulus Parameterizations: +- \b Cumulus \b Parameterizations - GFS Scale-Aware Arakawa Schubert (SAS) Scheme - \subpage GFS_SAMFdeep - \subpage GFS_SAMFshal @@ -30,33 +29,28 @@ parameterizations in suites. - \ref cu_gf_deep_group - \ref cu_gf_sh_group -- Microphysics: +- \b Microphysics - \subpage GFDL_cloud - - \subpage fast_sat_adj - \subpage CPT_MG3 - \subpage GSD_THOMPSON -- Stochastic: - - \subpage STOCHY_PHYS - - \subpage surf_pert - -- Ozone: +- \b Ozone \b Photochemical \b Production \b and \b Loss - \subpage GFS_OZPHYS - \ref GFS_ozphys_2015 -- Water Vapor Photochemical Production and Loss: +- \b Water \b Vapor \b Photochemical \b Production \b and \b Loss - \subpage GFS_H2OPHYS -- Gravity Wave Drag: +- \b Gravity \b Wave \b Drag - \subpage GFS_GWDPS - \subpage GFS_GWDC -- Surface Layer and Simplified Ocean and Sea Ice Representation: +- \b Surface \b Layer \b and \b Simplified \b Ocean \b and \b Sea \b Ice \b Representation - \subpage GFS_SFCLYR - \subpage GFS_NSST - \subpage GFS_SFCSICE -- Others: +- \b Others - \subpage GFS_RAYLEIGH - \subpage GFS_CALPRECIPTYPE @@ -86,10 +80,10 @@ to the parameterization. \section allsuite_overview Physics Suites The CCPP v3 includes the suite used in the GFS v15 implemented operationally in June 2019 (suite GFS_v15). Additionally, it includes three -developmental suites which are undergoing testing for possible future implementation in the UFS. Suite GFS_v15 plus is identical to suite +developmental suites which are undergoing testing for possible future implementation in the UFS. Suite GFS_v15plus is identical to suite GFS_v15 except for a replacement in the PBL parameterization (Han et al. 2019 \cite Han_2019 ). Suite MGCSAW differs from GFS_v15 as it contains different convection and microphysics schemes made available through a NOAA Climate Process Team (CPT) with components developed -at multiple research centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Suite GSD_v0 differs from v15 as it +at multiple research centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Suite GSD_v0 differs from GFS_v15 as it uses the convection, microphysics, and boundary layer schemes employed in the Rapid Refresh (RAP) and High-Resolution Rapid Refresh (HRRR \cite Benjamin_2016 ) operational models and was assembled by NOAA/GSD. An assessment of an earlier version of these suites can be found in the UFS portal diff --git a/physics/docs/pdftxt/all_shemes_list.txt.FV3 b/physics/docs/pdftxt/all_shemes_list.txt.FV3 new file mode 100644 index 000000000..9294027dd --- /dev/null +++ b/physics/docs/pdftxt/all_shemes_list.txt.FV3 @@ -0,0 +1,110 @@ +/** +\page allscheme_page Parameterizations and Suites Overview + +\section allscheme_overview Physics Parameterizations + +In the CCPP-Physics v3.0 release, each parameterization is in its own modern Fortran module, + which facilitates model development and +code maintenance. While some individual parameterization can be invoked for the GMTB SCM, most users will assemble the +parameterizations in suites. + +- Radiation + - \subpage GFS_RRTMG + +- PBL and Turbulence + - \subpage GFS_HEDMF + - \subpage GFS_SATMEDMF + - \subpage GSD_MYNNEDMF + +- Land Surface Model + - \subpage GFS_NOAH + - \subpage surf_pert + - \subpage GSD_RUCLSM + +- Cumulus Parameterizations + - GFS Scale-Aware Arakawa Schubert (SAS) Scheme + - \subpage GFS_SAMFdeep + - \subpage GFS_SAMFshal + - \subpage CSAW_scheme + - \subpage GSD_CU_GF + - \ref cu_gf_deep_group + - \ref cu_gf_sh_group + +- Microphysics + - \subpage GFDL_cloud + - \subpage fast_sat_adj (not available for the GMTB SCM) + - \subpage CPT_MG3 + - \subpage GSD_THOMPSON + +- Stochastic (not available for the GMTB SCM) + - \subpage STOCHY_PHYS + - \subpage surf_pert (only applicable to \ref GFS_NOAH ) + +- Ozone + - \subpage GFS_OZPHYS + - \ref GFS_ozphys_2015 + +- Water Vapor Photochemical Production and Loss + - \subpage GFS_H2OPHYS + +- Gravity Wave Drag + - \subpage GFS_GWDPS + - \subpage GFS_GWDC + +- Surface Layer and Simplified Ocean and Sea Ice Representation + - \subpage GFS_SFCLYR + - \subpage GFS_NSST + - \subpage GFS_SFCSICE + +- Others + - \subpage GFS_RAYLEIGH + - \subpage GFS_CALPRECIPTYPE + +In addition to the physical schemes themselves, this scientific documentation also covers four modules that define physics/radiation functions, parameters and constants: + - \ref func_phys + - \ref phy_sparam + - \ref physcons + - \ref radcons + +The input information for the physics include the values of the gridbox mean prognostic variables (wind components, temperature, +specific humidity, cloud fraction, water contents for cloud liquid, cloud ice, rain, snow, graupel, and ozone concentration), the provisional + dynamical tendencies for the same variables and various surface fields, both fixed and variable. + +The time integration of the physics suites is based on the following: +- The tendencies from the different physical processes are computed by the parameterizations or derived in separate interstitial routines +- The first part of the suite, comprised of the parameterizations for radiation, surface layer, surface (land, ocean, and sea ice), boundary layer, +orographic gravity wave drag, and Rayleigh damping, is computed using a hybrid of parallel and sequential splitting described in Donahue and Caldwell(2018) +\cite donahue_and_caldwell_2018, a method in which the various parameterizations use the same model state as input but are impacted by the preceding +parameterizations. The tendencies from the various parameterizations are then added together and used to update the model state. +- The surface parameterizations (land, ocean and sea ice) are invoked twice in a loop, with the first time to create a guess, and the second time to +produce the tendencies. +- The second part of the physics suite, comprised of the parameterizations of ozone, stratospheric water vapor, deep convection, convective gravity wave drag, +shallow convection, and microphysics, is computed using sequential splitting in the order listed above, in which the model state is updated between calls +to the parameterization. +- If the in-core saturation adjustment is used (\p do_sat_adj=.true.), it is invoked at shorter timesteps along with the dynamical solver. + +\section allsuite_overview Physics Suites + +The CCPP v3 includes the suite used in the GFS v15 implemented operationally in June 2019 (suite GFS_v15). Additionally, it includes three +developmental suites which are undergoing testing for possible future implementation in the UFS. Suite GFS_v15plus is identical to suite +GFS_v15 except for a replacement in the PBL parameterization (Han et al. 2019 \cite Han_2019 ). Suite MGCSAW differs from GFS_v15 as it +contains different convection and microphysics schemes made available through a NOAA Climate Process Team (CPT) with components developed +at multiple research centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Suite GSD_v0 differs from GFS_v15 as it +uses the convection, microphysics, and boundary layer schemes employed in the Rapid Refresh (RAP) and High-Resolution Rapid Refresh (HRRR \cite Benjamin_2016 ) +operational models and was assembled by NOAA/GSD. An assessment of an earlier version of these suites can be found in + the UFS portal +and in the GMTB website . + +Table 1. Physics suite options included in this documentation. +\tableofcontents +| Phys suites | GFS_v15 | GFS_v15plus | MGCSAW | GSD_v0 | +|------------------|----------------------|----------------------|---------------------|----------------------| +| Deep Cu | \ref GFS_SAMFdeep | \ref GFS_SAMFdeep | \ref CSAW_scheme | \ref GSD_CU_GF | +| Shallow Cu | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GSD_MYNNEDMF and \ref cu_gf_sh_group | +| Microphysics | \ref GFDL_cloud | \ref GFDL_cloud | \ref CPT_MG3 | \ref GSD_THOMPSON | +| PBL/TURB | \ref GFS_HEDMF | \ref GFS_SATMEDMF | \ref GFS_HEDMF | \ref GSD_MYNNEDMF | +| Land | \ref GFS_NOAH | \ref GFS_NOAH | \ref GFS_NOAH | \ref GSD_RUCLSM | +\tableofcontents + + +*/ diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 0444044cf..75e5c09f9 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -3,17 +3,17 @@ At runtime, the SCM and the UFS Atmosphere access runtime configurations from file \c input.nml. This file contains various namelists that control aspects of the I/O, dynamics, physics etc. Most physics-related options are grouped into -two namelists:&gfs_physics_nml and &gfdl_cloud_microphysics_nml, with additional specifications for stochastic physics in -namelists &stochy_nam and &nam_sfcperts. +two namelists:\b &gfs_physics_nml and \b &gfdl_cloud_microphysics_nml, with additional specifications for stochastic physics in +namelists \b &stochy_nam and \b &nam_sfcperts. -Namelist &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in +Namelist \b &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in module_gfdl_cloud_microphys.F90. -Namelist &gfs_physics_nml pertains to all of the suites used, but some of the variables are only relevant for specific +Namelist \b &gfs_physics_nml pertains to all of the suites used, but some of the variables are only relevant for specific parameterizations. Its variables are defined in file GFS_typedefs.F90 in the host model. -Namelist &stochy_nam specifies options for the use of SPPT, SKEB and SHUM, while namelist &nam_sfcperts specifies whether -and how stochastic perturbations are used in the loah Land surface model. +Namelist \b &stochy_nam specifies options for the use of SPPT, SKEB and SHUM, while namelist \b &nam_sfcperts specifies whether +and how stochastic perturbations are used in the Noah Land Surface Model. diff --git a/physics/module_sf_ruclsm.F90 b/physics/module_sf_ruclsm.F90 index be2a74957..9ffc8f49b 100644 --- a/physics/module_sf_ruclsm.F90 +++ b/physics/module_sf_ruclsm.F90 @@ -57,107 +57,6 @@ MODULE module_sf_ruclsm !>\ingroup lsm_ruc_group !> The RUN LSM model is described in Smirnova et al.(1997) !! \cite Smirnova_1997 and Smirnova et al.(2000) \cite Smirnova_2000 -!>\param dt time step(second) -!>\param ktau number of time step -!>\param nsl number of soil layers -!>\param graupelncv. -!>\param snowncv -!>\param rainncv one time step grid scale precipitation (mm/step) -!>\param raincv one time step convective precipitation (mm/step) -!>\param zs depth of soil levels (\f$m\f$) -!>\param rainbl accumulated rain in mm between the PBL calls -!>\param snow snow water equivalent (\f$mm\f$) -!>\param snowh -!>\param snowc flag indicating snow coverage (1 for snow cover) -!>\param frzfrac fraction of frozen precipitation -!>\param frpcpn -!>\param rhosnf -!>\param precipfr time step frozen precipitation (\f$mm\f$) -!>\param z3d height(\f$m\f$) -!>\param p8w 3D pressure (\f$Pa\f$) -!>\param t3d temperature (\f$K\f$) -!>\param qv3d 3D water vapor mixing ratio (\f$Kg Kg^{-1}\f$) -!>\param qc3d 3D cloud water mixing ratio (\f$Kg Kg^{-1}\f$) -!>\param rho3d 3D air density (\f$Kg m^{-3}\f$) -!>\param glw downward longwave flux at ground surface (\f$Wm^{-2}\f$) -!>\param gsw absorbed shortwave flux at ground surface (\f$Wm^{-2}\f$) -!>\param emiss surface emissivity (between 0 and 1) -!>\param chklowq is either 0 or 1 (so far set equal to 1).used only in MYJPBL -!>\param chs -!>\param flqc surface exchange coefficient for moisture(\f$Kg m^{-2} s^{-1}\f$) -!>\param flhc surface exchange coefficient for heat(\f$Wm^{-2}s^{-1}K^{-1}\f$) -!>\param mavail -!>\param canwat canopy moisture content (\f$mm\f$) -!>\param vegfra vegetation fraction (between 0 and 100) -!>\param alb surface albedo (between 0 and 1) -!>\param znt roughness length (\f$m\f$) -!>\param z0 -!>\param snoalb maximum snow albedo (between 0 and 1) -!>\param albbck snow-free albedo (between 0 and 1) -!>\param landusef -!>\param nlcat -!>\param soilctop -!>\param nscat -!>\param qsfc -!>\param qsg -!>\param qvg -!>\param qcg -!>\param dew -!>\param soilt1 -!>\param tsnav -!>\param tbot soil temperature at lower boundary (\f$K\f$) -!>\param ivgtyp USGS vegetation type (24 classes) -!>\param isltyp STASGO soil type (16 classes) -!>\param xland land mask (1 for land, 2 for water) -!>\param iswater -!>\param isice -!>\param xice -!>\param xice_threshold -!>\param cp heat capacity at constant pressure for dry air (\f$J Kg^{-1} K^{-1}\f$) -!>\param rv -!>\param rd -!>\param g0 acceleration due to gravity (\f$m s^{-2}\f$) -!>\param pi -!>\param lv latent heat of melting (\f$J Kg^{-1}\f$) -!>\param stbolt Stefan-Boltzmann constant (\f$W m^{-2} K^{-4}\f$) -!>\param soilmois soil moisture content (volumetric fraction) -!>\param sh2o -!>\param smavail -!>\param smmax -!>\param tso soil temperature (\f$K\f$) -!>\param soilt surface temperature (\f$K\f$) -!>\param hfx upward heat flux at the surface (\f$W m^{-2}\f$) -!>\param qfx upward moisture flux at the surface (\f$Kg m^{-2} s^{-1}\f$) -!>\param lh upward latent heat flux (\f$W m^{-2}\f$) -!>\param infiltr -!>\param runoff1 -!>\param runoff2 -!>\param acrunoff run-total surface runoff (\f$mm\f$) -!>\param sfcexc -!>\param sfcevp -!>\param grdflx soil heat flux (\f$W m^{-2}\f$; negative, if downward from surface) -!>\param snowfallac run-total snowfall accumulation (\f$m\f$) -!>\param acsnow run-total SWE of snowfall (\f$mm\f$) -!>\param snom -!>\param smfr3d -!>\param keepfr3dflag -!>\param myj -!>\param shdmin -!>\param shdmax -!>\param rdlai2d -!>\param ims start index for i in memory -!>\param ime end index for i in memory -!>\param jms start index for j in memory -!>\param jme end index for j in memory -!>\param kms start index for k in memory -!>\param kme end index for k in memory -!>\param its -!>\param ite -!>\param jts -!>\param jte -!>\param kts -!>\param kte -!! !>\section gen_lsmruc GSD RUC LSM General Algorithm !! @{ SUBROUTINE LSMRUC( & From 2bb243daf1afea6f1beee35d56ad67b8c9fd53ab Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Thu, 13 Jun 2019 13:38:32 -0600 Subject: [PATCH 08/19] scidoc updates --- physics/aer_cloud.F | 20 ++++----- physics/cnvc90.f | 2 +- physics/cs_conv.F90 | 40 +++++++++--------- physics/cs_conv_aw_adj.F90 | 2 +- physics/cu_gf_deep.F90 | 26 +++++------- physics/cu_gf_driver.F90 | 4 +- physics/cu_gf_sh.F90 | 44 +++++++++++--------- physics/docs/ccppv3_doxyfile | 5 ++- physics/docs/pdftxt/CPT_adv_suite.txt | 10 ++--- physics/docs/pdftxt/GFDL_cloud.txt | 3 -- physics/docs/pdftxt/all_shemes_list.txt | 4 +- physics/docs/pdftxt/suite_input.nml.txt | 4 +- physics/funcphys.f90 | 4 +- physics/gfdl_fv_sat_adj.F90 | 6 +-- physics/micro_mg3_0.F90 | 54 ++++++++++++------------- physics/micro_mg_utils.F90 | 14 +++---- physics/moninedmf.f | 2 +- physics/mp_thompson.F90 | 2 +- physics/radiation_clouds.f | 19 ++++++--- physics/radlw_main.f | 10 +++-- physics/radsw_main.f | 12 ++++-- physics/satmedmfvdif.F | 1 - physics/sflx.f | 3 +- 23 files changed, 153 insertions(+), 138 deletions(-) diff --git a/physics/aer_cloud.F b/physics/aer_cloud.F index 1c6e27442..60df592b6 100644 --- a/physics/aer_cloud.F +++ b/physics/aer_cloud.F @@ -158,10 +158,6 @@ end subroutine aer_cloud_init !!\param dpre_in mass-weighted diameter of prexisting ice crystals (m) !!\param ccn_diagr8 array of supersaturations for CCN diagnostics (in-out) !!\param Ndropr8 Current droplet number concentration (\f$Kg^{-1}\f$) -!!\param qc Liquid water mixing ratio (Kg/Kg) -!!\param use_average_v .false. integrate over the updraft distribution. True: use the mean vertical velocity -!!\param CCN_param CCN activation parameterization. 1- Fountoukis and Nenes (2005), 2-Abdul_Razzak and Ghan (2002) (def = 2) -!!\param IN_param IN activation spectrum (default is 5) !!\param cdncr8 Activated cloud droplet number concentration (Kg-1) !!\param smaxliqr8 Maximum supersaturation w.r.t liquid during droplet activation !!\param incr8 Nucleated ice crystal concentration (Kg-1) @@ -172,14 +168,20 @@ end subroutine aer_cloud_init !!\param Ncdepr8 Nucleated nc by deposition ice nucleation (Kg-1) !!\param Ncdhfr8 Nucleated nc by immersion in aerosol (Kg -1) !!\param sc_icer8 Critical saturation ratio in cirrus -!!\param fdust_depr8 Fraction of deposition ice nuclei that are dust !!\param fdust_immr8 Fraction of immersion mixed-phase ice nuclei that are dust +!!\param fdust_depr8 Fraction of deposition ice nuclei that are dust !!\param fdust_dhfr8 Fraction of immersion ice nuclei that are dust (not mixed-phase) !!\param nlimr8 Limiting ice nuclei concentration (m-3) - -!=================================================================================== - - +!!\param use_average_v .false. integrate over the updraft distribution. True: use the mean vertical velocity +!!\param CCN_param CCN activation parameterization. 1- Fountoukis and Nenes (2005), 2-Abdul_Razzak and Ghan (2002) (def = 2) +!!\param IN_param IN activation spectrum (default is 5) +!!\param fd_dust +!!\param fd_soot +!!\param pfrz_inc_r8 +!!\param sigma_nuc +!!\param rhi_cell +!!\param nccn +!! subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, & & wparc_ls, Aer_Props, npre_in, dpre_in, ccn_diagr8, Ndropr8, & & cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, INimmr8, & diff --git a/physics/cnvc90.f b/physics/cnvc90.f index 800ccb5dc..1e95148be 100644 --- a/physics/cnvc90.f +++ b/physics/cnvc90.f @@ -37,7 +37,7 @@ end subroutine cnvc90_init !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! -!>\section gen_cnvc90_run GFS cnvc90_run General Algorithm +! \section gen_cnvc_run GFS cnvc90_run General Algorithm SUBROUTINE cnvc90_run(CLSTP,IM,IX,RN,KBOT,KTOP,KM,PRSI, & & ACV,ACVB,ACVT,CV,CVB,CVT,errmsg,errflg) diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index cb0c0b98b..eeda5fa1f 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -1859,7 +1859,7 @@ END SUBROUTINE CS_CUMLUS !*********************************************************************** !>\ingroup cs_scheme !! This subroutine calculates cloud base properties. - SUBROUTINE CUMBAS & !< cloud base + SUBROUTINE CUMBAS & ! cloud base ( IJSDIM, KMAX , & !DD dimensions KB , GCYM , KBMX , & ! output ntr , ntrq , & @@ -1881,15 +1881,15 @@ SUBROUTINE CUMBAS & !< cloud base logical lprnt ! ! [OUTPUT] - INTEGER KB (IJSDIM) !< cloud base - REAL(r8) GCYM (IJSDIM, KMAX) !< norm. mass flux (half lev) + INTEGER KB (IJSDIM) ! cloud base + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux (half lev) INTEGER KBMX - REAL(r8) GCHB (IJSDIM) !< cloud base MSE - REAL(r8) GCWB (IJSDIM) !< cloud base total water - REAL(r8) GCUB (IJSDIM) !< cloud base U - REAL(r8) GCVB (IJSDIM) !< cloud base V - REAL(r8) GCIB (IJSDIM) !< cloud base ice - REAL(r8) GCtrB (IJSDIM,ntrq:ntr) !< cloud base tracer + REAL(r8) GCHB (IJSDIM) ! cloud base MSE + REAL(r8) GCWB (IJSDIM) ! cloud base total water + REAL(r8) GCUB (IJSDIM) ! cloud base U + REAL(r8) GCVB (IJSDIM) ! cloud base V + REAL(r8) GCIB (IJSDIM) ! cloud base ice + REAL(r8) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracer !DDsigma added to arglist for AW, subcloud updraft profiles: temperature, water vapor ! total water, cloud water, and cloud ice respectively @@ -1897,22 +1897,22 @@ SUBROUTINE CUMBAS & !< cloud base REAL(r8), dimension(ijsdim,kmax,ntrq:ntr) :: gctrbl !DDsigmadiag ! ! [INPUT] - REAL(r8) GDH (IJSDIM, KMAX) !< moist static energy - REAL(r8) GDW (IJSDIM, KMAX) !< total water - REAL(r8) GDq (IJSDIM, KMAX, ntr) !< water vapor and tracer - REAL(r8) GDHS (IJSDIM, KMAX) !< saturate MSE - REAL(r8) GDQS (IJSDIM, KMAX) !< saturate humidity - REAL(r8) GDQI (IJSDIM, KMAX) !< cloud ice - REAL(r8) GDU (IJSDIM, KMAX) !< u-velocity - REAL(r8) GDV (IJSDIM, KMAX) !< v-velocity - REAL(r8) GDZM (IJSDIM, KMAX+1) !< Altitude (half lev) - REAL(r8) GDPM (IJSDIM, KMAX+1) !< pressure (half lev) + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDq (IJSDIM, KMAX, ntr) ! water vapor and tracer + REAL(r8) GDHS (IJSDIM, KMAX) ! saturate MSE + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDU (IJSDIM, KMAX) ! u-velocity + REAL(r8) GDV (IJSDIM, KMAX) ! v-velocity + REAL(r8) GDZM (IJSDIM, KMAX+1) ! Altitude (half lev) + REAL(r8) GDPM (IJSDIM, KMAX+1) ! pressure (half lev) REAL(r8) FDQS (IJSDIM, KMAX) REAL(r8) GAM (IJSDIM, KMAX) INTEGER ISTS, IENS ! ! [INTERNAL WORK] - REAL(r8) CBASE (IJSDIM) !< one over cloud base height + REAL(r8) CBASE (IJSDIM) ! one over cloud base height ! REAL(r8) CBASEP(IJSDIM) ! cloud base pressure REAL(r8) DELZ, GAMX, wrk ! REAL(r8) DELZ, QSL, GAMX, wrk diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 index 871fbe213..4e84911b3 100644 --- a/physics/cs_conv_aw_adj.F90 +++ b/physics/cs_conv_aw_adj.F90 @@ -48,7 +48,7 @@ end subroutine cs_conv_aw_adj_finalize !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! -!>\section gen_cs_conv_aw_adj_run CPT cs_conv_aw_adj_run General Algorithm +!\section gen_cs_conv_aw_adj_run CPT cs_conv_aw_adj_run General Algorithm subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & ntrac, ncld, ntcw, ntclamt, nncl, con_g, sigmafrac, & gt0, gq0, save_t, save_q, prsi, cldfrac, subcldfrac, & diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 7bf08e6b7..24d57ca8c 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -1,7 +1,7 @@ !>\file cu_gf_deep.F90 !! This file is the Grell-Freitas deep convection scheme. -!>\defgroup cu_gf_deep_group GSD Grell-Freitas Deep Convection Main +!>\defgroup cu_gf_deep_group Grell-Freitas Deep Convection Module !>\ingroup cu_gf_group module cu_gf_deep use machine , only : kind_phys @@ -55,7 +55,7 @@ subroutine cu_gf_deep_run( & ,ichoice & ! choice of closure, use "0" for ensemble average ,ipr & ! this flag can be used for debugging prints ,ccn & ! not well tested yet - ,dtime & ! + ,dtime & ! dt over which forcing is applied ,imid & ! flag to turn on mid level convection ,kpbl & ! level of boundary layer height ,dhdt & ! boundary layer forcing (one closure for shallow) @@ -2316,6 +2316,13 @@ end subroutine cup_dd_moisture !!\param psur surface pressure !!\param ierr error value, maybe modified in this routine !!\param tcrit 258.K +!!\param itest +!!\param itf +!!\param ktf +!!\param its +!!\param ite +!!\param kts +!!\param kte subroutine cup_env(z,qes,he,hes,t,q,p,z1, & psur,ierr,tcrit,itest, & itf,ktf, & @@ -2453,6 +2460,7 @@ end subroutine cup_env !!\param psur surface pressure !!\param ierr error value, maybe modified in this routine !!\param z1 terrain elevation +!!\param itf,ktf,its,ite,kts,kte horizontal and vertical dimension subroutine cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup, & he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & ierr,z1, & @@ -3163,8 +3171,6 @@ subroutine cup_minimi(array,ks,kend,kt,ierr, & end subroutine cup_minimi !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_up_aa0(aa0,z,zu,dby,gamma_cup,t_cup, & kbcon,ktop,ierr, & itf,ktf, & @@ -3237,8 +3243,6 @@ end subroutine cup_up_aa0 !==================================================================== !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine neg_check(name,j,dt,q,outq,outt,outu,outv, & outqc,pret,its,ite,kts,kte,itf,ktf,ktop) @@ -3587,8 +3591,6 @@ subroutine cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc, & end subroutine cup_output_ens_3d !------------------------------------------------------- !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav, & p_cup,kbcon,ktop,dby,clw_all,xland1, & q,gamma_cup,zu,qes_cup,k22,qe_cup, & @@ -3900,8 +3902,6 @@ end subroutine cup_up_moisture !-------------------------------------------------------------------- !>\ingroup cu_gf_deep_group -!> This function calculates -!>\param real function satvap(temp2) implicit none real(kind=kind_phys) :: temp2, temp, toot, toto, eilog, tsot, & @@ -4066,8 +4066,6 @@ subroutine rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo end subroutine rates_up_pdf !------------------------------------------------------------------------- !>\ingroup cu_gf_deep_group -!> This subroutine calculates -!>\param subroutine get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev) implicit none @@ -4575,7 +4573,6 @@ function deriv3(xx, xi, yi, ni, m) end function deriv3 !============================================================================================= !>\ingroup cu_gf_deep_group -!> This subroutine calcualtes subroutine get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & ,up_massentro, up_massdetro ,up_massentr, up_massdetr & @@ -4693,7 +4690,6 @@ end subroutine get_lateral_massflux !---meltglac------------------------------------------------- !------------------------------------------------------------------------------------ !>\ingroup cu_gf_deep_group -!> This subroutine calculates subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer & ,itf,ktf,its,ite, kts,kte, cumulus ) implicit none @@ -4785,7 +4781,6 @@ end subroutine get_partition_liq_ice !------------------------------------------------------------------------------------ !>\ingroup cu_gf_deep_group -!> This subroutine calculates subroutine get_melting_profile(ierr,tn_cup,po_cup, p_liq_ice,melting_layer,qrco & ,pwo,edto,pwdo,melting & ,itf,ktf,its,ite, kts,kte, cumulus ) @@ -4860,7 +4855,6 @@ end subroutine get_melting_profile !---meltglac------------------------------------------------- !-----srf-08aug2017-----begin !>\ingroup cu_gf_deep_group -!> This subroutine calculates subroutine get_cloud_top(name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, & kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,klcl,hcot) implicit none diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 1265a7112..2695ace2d 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -62,8 +62,8 @@ end subroutine cu_gf_driver_finalize ! t = current temp (t2di + physics up to now) !=================== -!> \defgroup cu_gf_group GSD Scale-Aware Grell-Freitas Convection Scheme Module -!>\defgroup cu_gf_driver GSD Grell-Freitas Convection Scheme Driver +!> \defgroup cu_gf_group Grell-Freitas Convection Scheme Module +!>\defgroup cu_gf_driver Grell-Freitas Convection Scheme Driver Module !> \ingroup cu_gf_group !! \section arg_table_cu_gf_driver_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index faca8839f..5eb582f2d 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -1,21 +1,37 @@ !>\file cu_gf_sh.F90 !! This file contains -!>\defgroup cu_gf_sh_group GSD Grell-Freitas Shallow Convection Main +!>\defgroup cu_gf_sh_group Grell-Freitas Shallow Convection Module !> \ingroup cu_gf_group -!! module cup_gf_sh will call shallow convection as described in Grell and +module cu_gf_sh + use machine , only : kind_phys + !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 + real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 + real(kind=kind_phys), parameter:: g =9.81 + real(kind=kind_phys), parameter:: cp =1004. + real(kind=kind_phys), parameter:: xlv=2.5e6 + real(kind=kind_phys), parameter:: r_v=461. + real(kind=kind_phys), parameter:: c0_shal=.001 + real(kind=kind_phys), parameter:: fluxtune=1.5 + +contains + +!>\ingroup cu_gf_sh_group +!> GF shallow convection as described in Grell and !! Freitas (2014) \cite grell_and_freitas_2014. input variables are: +!!\param us x wind updated by physics +!!\param vs y wind updated by physics !!\param zo height at model levels !!\param t,tn temperature without and with forcing at model levels !!\param q,qo mixing ratio without and with forcing at model levels !!\param po pressure at model levels (mb) !!\param psur surface pressure (mb) !!\param z1 surface height -!!\param dhdt forcing for boundary layer equilibrium +!!\param dhdt forcing for boundary layer equilibrium !!\param hfx,qfx in w/m2 (positive, if upward from sfc) !!\param kpbl level of boundaty layer height !!\param xland land mask (1. for land) -!!\param ichoice which closure to choose +!!\param ichoice which closure to choose !!\n 1: old g !!\n 2: zws !!\n 3: dhdt @@ -37,21 +53,10 @@ !! not included (kg/kg) !!\param cnvwt required for gfs physics !!\param itf,ktf,its,ite, kts,kte are dimensions -!!\param ztexec,zqexec excess temperature and moisture for updraft -module cu_gf_sh - use machine , only : kind_phys - !real(kind=kind_phys), parameter:: c1_shal=0.0015! .0005 - real(kind=kind_phys), parameter:: c1_shal=0. !0.005! .0005 - real(kind=kind_phys), parameter:: g =9.81 - real(kind=kind_phys), parameter:: cp =1004. - real(kind=kind_phys), parameter:: xlv=2.5e6 - real(kind=kind_phys), parameter:: r_v=461. - real(kind=kind_phys), parameter:: c0_shal=.001 - real(kind=kind_phys), parameter:: fluxtune=1.5 - -contains - +!!\param ipr horizontal index of printed column +!!\param tropics =0 !>\section gen_cu_gf_sh_run GSD cu_gf_sh_run General Algorithm +!> @{ subroutine cu_gf_sh_run ( & us,vs,zo,t,q,z1,tn,qo,po,psur,dhdt,kpbl,rho, & ! input variables, must be supplied hfx,qfx,xland,ichoice,tcrit,dtime, & @@ -276,7 +281,7 @@ subroutine cu_gf_sh_run ( & !- moisture excess zqexec(i) = max(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.) endif - !- zws for shallow convection closure (grant 2001) + !> - Calculate zws for shallow convection closure (grant 2001) !- height of the pbl zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i))) zws(i) = 1.2*zws(i)**.3333 @@ -929,4 +934,5 @@ subroutine cu_gf_sh_run ( & ! enddo end subroutine cu_gf_sh_run +!> @} end module cu_gf_sh diff --git a/physics/docs/ccppv3_doxyfile b/physics/docs/ccppv3_doxyfile index be9bfe1f2..6933751a4 100644 --- a/physics/docs/ccppv3_doxyfile +++ b/physics/docs/ccppv3_doxyfile @@ -133,7 +133,7 @@ INPUT = pdftxt/mainpage.txt \ ### pdftxt/GFS_STOCHY_PHYS.txt \ pdftxt/suite_input.nml.txt \ ### in-core MP -### ../gfdl_fv_sat_adj.F90 \ + ../gfdl_fv_sat_adj.F90 \ ### time_vary ../GFS_phys_time_vary.fv3.F90 \ ../ozne_def.f \ @@ -392,7 +392,8 @@ SEARCH_INCLUDES = YES INCLUDE_PATH = INCLUDE_FILE_PATTERNS = PREDEFINED = CCPP \ - GEOS5 + MULTI_GASES \ + 0 EXPAND_AS_DEFINED = SKIP_FUNCTION_MACROS = YES TAGFILES = diff --git a/physics/docs/pdftxt/CPT_adv_suite.txt b/physics/docs/pdftxt/CPT_adv_suite.txt index bca25db96..7617d9df3 100644 --- a/physics/docs/pdftxt/CPT_adv_suite.txt +++ b/physics/docs/pdftxt/CPT_adv_suite.txt @@ -1,9 +1,9 @@ /** -\page MGCSAW_page MGCSAW Suite +\page csawmg_page csawmg Suite -\section MGCSAW_suite_overview Overview +\section csawmg_suite_overview Overview -The advanced MGCSAW physics suite uses the parameterizations in the following order: +The advanced csawmg physics suite uses the parameterizations in the following order: - \ref GFS_RRTMG - \ref GFS_SFCLYR - \ref GFS_NSST @@ -23,11 +23,11 @@ The advanced MGCSAW physics suite uses the parameterizations in the following or \section sdf_cpt_suite Suite Definition File -The advanced MGCSAW physics suite uses the parameterizations in the following order, as defined in \c SCM_MGCSAW : +The advanced csawmg physics suite uses the parameterizations in the following order, as defined in \c SCM_csawmg : \code - + diff --git a/physics/docs/pdftxt/GFDL_cloud.txt b/physics/docs/pdftxt/GFDL_cloud.txt index 414d41374..200497f89 100644 --- a/physics/docs/pdftxt/GFDL_cloud.txt +++ b/physics/docs/pdftxt/GFDL_cloud.txt @@ -45,9 +45,6 @@ and ocean (larger sub-grid variability appears in larger area). Horizontal sub-g relative humidity calculation, evaporation and condensation processes. Scale-awareness is achieved by this horizontal subgrid variability and a \f$2^{nd}\f$ order FV-type vertical reconstruction (Lin et al. (1994) \cite lin_et_al_1994). -\section nml_opt Namelist Option -\ref gfdl_cloud_microphysics_nml - \section intro_GFDL_cloud Intraphysics Communication + For GFDL Cloud MP: \ref arg_table_gfdl_cloud_microphys_run + For GFDL Fast Physics: \ref arg_table_fv_sat_adj_run diff --git a/physics/docs/pdftxt/all_shemes_list.txt b/physics/docs/pdftxt/all_shemes_list.txt index 39b4917ef..8762cf0d1 100644 --- a/physics/docs/pdftxt/all_shemes_list.txt +++ b/physics/docs/pdftxt/all_shemes_list.txt @@ -81,7 +81,7 @@ to the parameterization. The CCPP v3 includes the suite used in the GFS v15 implemented operationally in June 2019 (suite GFS_v15). Additionally, it includes three developmental suites which are undergoing testing for possible future implementation in the UFS. Suite GFS_v15plus is identical to suite -GFS_v15 except for a replacement in the PBL parameterization (Han et al. 2019 \cite Han_2019 ). Suite MGCSAW differs from GFS_v15 as it +GFS_v15 except for a replacement in the PBL parameterization (Han et al. 2019 \cite Han_2019 ). Suite csawmg differs from GFS_v15 as it contains different convection and microphysics schemes made available through a NOAA Climate Process Team (CPT) with components developed at multiple research centers and universities, including Colorado State, Utah, NASA, NCAR, and EMC. Suite GSD_v0 differs from GFS_v15 as it uses the convection, microphysics, and boundary layer schemes employed in the Rapid Refresh (RAP) and High-Resolution Rapid Refresh (HRRR \cite Benjamin_2016 ) @@ -91,7 +91,7 @@ and in the GMTB website < Table 1. Physics suite options included in this documentation. \tableofcontents -| Phys suites | GFS_v15 | GFS_v15plus | MGCSAW | GSD_v0 | +| Phys suites | GFS_v15 | GFS_v15plus | csawmg | GSD_v0 | |------------------|----------------------|----------------------|---------------------|----------------------| | Deep Cu | \ref GFS_SAMFdeep | \ref GFS_SAMFdeep | \ref CSAW_scheme | \ref GSD_CU_GF | | Shallow Cu | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GFS_SAMFshal | \ref GSD_MYNNEDMF and \ref cu_gf_sh_group | diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 75e5c09f9..a9b6734ed 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -234,7 +234,7 @@ and how stochastic perturbations are used in the Noah Land Surface Model.
NML Description
aero_in gfs_control_type logical flag for using aerosols in Morrison-Gettelman microphysics .false.
iau_delthrs gfs_control_type incremental analysis update (IAU) time interval in hours 6
iaufhrs gfs_control_type forecast hours associated with increment files -1 -
\b Parameters \b Specific \b to \b MGCSAW \b Suite +
\b Parameters \b Specific \b to \b csawmg \b Suite
crtrh(3) gfs_control_type critical relative humidity at the surface, PBL top and at the top of the atmosphere 0.90,0.90,0.90
cscnv gfs_control_type logical flag for Chikira-Sugiyama deep convection .false.
do_aw gfs_control_type flag for Arakawa-Wu scale-awere adjustment .false. @@ -344,7 +344,7 @@ and how stochastic perturbations are used in the Noah Land Surface Model. 1
lsoil_lsm gfs_control_type number of soil layers internal to land surface model -1 -
\b Stochastic \Physics \b Specific \b Parameters +
\b Stochastic \b Physics \b Specific \b Parameters
do_sppt gfs_control_type flag for stochastic SPPT option .false.
do_shum gfs_control_type flag for stochastic SHUM option .false.
do_skeb gfs_control_type flag for stochastic SKEB option .false. diff --git a/physics/funcphys.f90 b/physics/funcphys.f90 index 1b50ad185..950698c97 100644 --- a/physics/funcphys.f90 +++ b/physics/funcphys.f90 @@ -788,7 +788,7 @@ subroutine gpvs !! computed in gpvs(). See documentation for fpvsx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] t real, temperature in Kelvin -!>\param[out] fpvs real, saturation vapor pressure in Pascals +!\param[out] fpvs real, saturation vapor pressure in Pascals elemental function fpvs(t) !$$$ Subprogram Documentation Block ! @@ -838,7 +838,7 @@ elemental function fpvs(t) !! computed in gpvs(). See documentation for fpvsx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] t real, temperatue in Kelvin -!>\param[out] fpvsq real, saturation vapor pressure in Pascals +!\param[out] fpvsq real, saturation vapor pressure in Pascals elemental function fpvsq(t) !$$$ Subprogram Documentation Block ! diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/gfdl_fv_sat_adj.F90 index 32f360034..90ed65e19 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/gfdl_fv_sat_adj.F90 @@ -1,5 +1,5 @@ !>\file gfdl_fv_sat_adj.F90 -!! This file contains the fast saturation adjustment in the GFDL cloud microphysics. +!! This file contains the GFDL in-core fast saturation adjustment. !! and it is an "intermediate physics" implemented in the remapping Lagrangian to !! Eulerian loop of FV3 solver. !*********************************************************************** @@ -23,8 +23,8 @@ !* If not, see . !*********************************************************************** -!> This module is part of the GFDL Cloud MP and it is the CCPP-compliant -!! fast phyiscs called in FV3 dynamics solver. +!> This module contains the GFDL in-core fast saturation adjustment +!! called in FV3 dynamics solver. module fv_sat_adj ! Modules Included: ! diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index fc2d4733b..671290749 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -272,37 +272,37 @@ subroutine micro_mg_init( & ! !----------------------------------------------------------------------- - integer, intent(in) :: kind !< Kind used for reals + integer, intent(in) :: kind ! Kind used for reals real(r8), intent(in) :: gravit real(r8), intent(in) :: rair real(r8), intent(in) :: rh2o real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmelt_in !< Freezing point of water (K) + real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) real(r8), intent(in) :: latvap real(r8), intent(in) :: latice - real(r8), intent(in) :: rhmini_in !< Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. real(r8), intent(in) :: micro_mg_dcs real(r8), intent(in) :: ts_auto(2) real(r8), intent(in) :: mg_qcvar !++ag !MG3 dense precipitating ice. Note, only 1 can be true, or both false. - logical, intent(in) :: micro_mg_do_graupel_in !< .true. = configure with graupel - !< .false. = no graupel (hail possible) - logical, intent(in) :: micro_mg_do_hail_in !< .true. = configure with hail - !< .false. = no hail (graupel possible) + logical, intent(in) :: micro_mg_do_graupel_in ! .true. = configure with graupel + ! .false. = no graupel (hail possible) + logical, intent(in) :: micro_mg_do_hail_in ! .true. = configure with hail + ! .false. = no hail (graupel possible) !--ag - logical, intent(in) :: microp_uniform_in !< .true. = configure uniform for sub-columns - !< .false. = use w/o sub-columns (standard) - logical, intent(in) :: do_cldice_in !< .true. = do all processes (standard) - !< .false. = skip all processes affecting cloud ice - logical, intent(in) :: use_hetfrz_classnuc_in !< use heterogeneous freezing + logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns + ! .false. = use w/o sub-columns (standard) + logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) + ! .false. = skip all processes affecting cloud ice + logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing - character(len=16),intent(in) :: micro_mg_precip_frac_method_in !< type of precipitation fraction method - real(r8), intent(in) :: micro_mg_berg_eff_factor_in !< berg efficiency factor - logical, intent(in) :: allow_sed_supersat_in !< allow supersaturated conditions after sedimentation loop - logical, intent(in) :: do_sb_physics_in !< do SB autoconversion and accretion physics + character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop + logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics logical, intent(in) :: do_ice_gmao_in logical, intent(in) :: do_liq_liu_in @@ -4444,18 +4444,18 @@ end subroutine micro_mg_tend !======================================================================== !>\ingroup mg3_mp -!! This subroutine calculates effective radius for rain + cloud. +!! This subroutine calculates effective radius for rain and cloud. subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) - integer, intent(in) :: mgncol, nlev - real(r8), dimension(mgncol,nlev), intent(in) :: lamr !< rain size parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: n0r !< rain size parameter (intercept) - real(r8), dimension(mgncol,nlev), intent(in) :: lamc !< size distribution parameter (slope) - real(r8), dimension(mgncol,nlev), intent(in) :: pgam !< droplet size parameter - real(r8), dimension(mgncol,nlev), intent(in) :: qric !< in-cloud rain mass mixing ratio - real(r8), dimension(mgncol,nlev), intent(in) :: qcic !< in-cloud cloud liquid - real(r8), dimension(mgncol,nlev), intent(in) :: ncic !< in-cloud droplet number concentration - - real(r8), dimension(mgncol,nlev), intent(inout) :: rercld !< effective radius calculation for rain + cloud + integer, intent(in) :: mgncol, nlev ! horizontal and vertical dimension + real(r8), dimension(mgncol,nlev), intent(in) :: lamr ! rain size parameter (slope) + real(r8), dimension(mgncol,nlev), intent(in) :: n0r ! rain size parameter (intercept) + real(r8), dimension(mgncol,nlev), intent(in) :: lamc ! size distribution parameter (slope) + real(r8), dimension(mgncol,nlev), intent(in) :: pgam ! droplet size parameter + real(r8), dimension(mgncol,nlev), intent(in) :: qric ! in-cloud rain mass mixing ratio + real(r8), dimension(mgncol,nlev), intent(in) :: qcic ! in-cloud cloud liquid + real(r8), dimension(mgncol,nlev), intent(in) :: ncic ! in-cloud droplet number concentration + + real(r8), dimension(mgncol,nlev), intent(inout) :: rercld ! effective radius calculation for rain + cloud ! combined size of precip & cloud drops real(r8) :: Atmp diff --git a/physics/micro_mg_utils.F90 b/physics/micro_mg_utils.F90 index fe1c8c8b0..7da528143 100644 --- a/physics/micro_mg_utils.F90 +++ b/physics/micro_mg_utils.F90 @@ -793,10 +793,10 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) end subroutine size_dist_param_ice_vect !>\ingroup micro_mg_utils_mod +!> Finds the average diameter of particles given their density, and +!! mass/number concentrations in the air. +!! Assumes that diameter follows an exponential distribution. real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) - !> Finds the average diameter of particles given their density, and - !! mass/number concentrations in the air. - !! Assumes that diameter follows an exponential distribution. real(r8), intent(in) :: q !< mass mixing ratio real(r8), intent(in) :: n !< number concentration (per volume) real(r8), intent(in) :: rho_air !< local density of the air @@ -807,9 +807,9 @@ real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) end function avg_diameter !>\ingroup mg2mg3 +!> Finds a coefficient for process rates based on the relative variance +!! of cloud water. elemental function var_coef_r8(relvar, a) result(res) - !> Finds a coefficient for process rates based on the relative variance - !! of cloud water. real(r8), intent(in) :: relvar real(r8), intent(in) :: a real(r8) :: res @@ -819,9 +819,9 @@ elemental function var_coef_r8(relvar, a) result(res) end function var_coef_r8 !>\ingroup mg2mg3 +!> Finds a coefficient for process rates based on the relative variance +!! of cloud water. elemental function var_coef_integer(relvar, a) result(res) - !> Finds a coefficient for process rates based on the relative variance - !! of cloud water. real(r8), intent(in) :: relvar integer, intent(in) :: a real(r8) :: res diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 363484457..76bc62298 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -1094,7 +1094,7 @@ subroutine hedmf_run (ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & ! compute tke dissipation rate ! !> ## Calculate heating due to TKE dissipation and add to the tendency for temperature -!! Following Han et al. (2015) \cite han_et_al_2015 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2015) \cite han_et_al_2015 for the PBL and equation 16 for the surface layer. +!! Following Han et al. (2016) \cite Han_2016 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2016) \cite Han_2016 for the PBL and equation 16 for the surface layer. if(dspheat) then ! do k = 1,km1 diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index df4a5de73..fb4d3d4cb 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -147,7 +147,7 @@ end subroutine mp_thompson_init #if 0 -!! \section arg_table_mp_thompson_run Argument Table +!> \section arg_table_mp_thompson_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |-----------------|-----------------------------------------------------------------------|-----------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| !! | ncol | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index 7f8d49c23..abc063953 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -845,6 +845,8 @@ end subroutine progcld1 !!\param delp (IX,NLAY), model layer pressure thickness in mb (100Pa) !!\param IX horizontal dimention !!\param NLAY,NLP1 vertical layer/level dimensions +!!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation +!!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -860,7 +862,7 @@ end subroutine progcld1 !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (IX), clouds decorrelation length (km) !>\section gen_progcld2 progcld2 General Algorithm -!! @{ +!> @{ subroutine progcld2 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, & @@ -1265,7 +1267,7 @@ subroutine progcld2 & return !................................... end subroutine progcld2 -!! @} +!> @} !----------------------------------- !> \ingroup module_radiation_clouds @@ -1279,6 +1281,8 @@ end subroutine progcld2 !!\param qstl (ix,nlay), layer saturate humidity in gm/gm !!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) !!\param clw (ix,nlay), layer cloud condensate amount +!!\param cnvw (ix,nlay), layer convective cloud condensate +!!\param cnvc (ix,nlay), layer convective cloud cover !!\param xlat (ix), grid latitude in radians, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment !!\param xlon (ix), grid longitude in radians (not used) @@ -1684,6 +1688,8 @@ end subroutine progcld3 !!\param xlon (ix), grid longitude in radians (not used) !!\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) !!\param cldtot (ix,nlay), layer total cloud fraction +!!\param dz (ix,nlay), layer thickness (km) +!!\param delp (ix,nlay), model layer pressure thickness in mb (100Pa) !!\param ix horizontal dimension !!\param nlay vertical layer dimension !!\param nlp1 vertical level dimension @@ -1700,6 +1706,7 @@ end subroutine progcld3 !!\param clds fraction of clouds for low, mid, hi cloud tops !!\param mtop vertical indices for low, mid, hi cloud tops !!\param mbot vertical indices for low, mid, hi cloud bases +!!\param de_lgth clouds decorrelation length (km) !>\section gen_progcld4 progcld4 General Algorithm !! @{ subroutine progcld4 & @@ -2014,6 +2021,8 @@ end subroutine progcld4 !! range, otherwise see in-line comment !>\param xlon (ix), grid longitude in radians (not used) !>\param slmsk (ix), sea/land mask array (sea:0, land:1, sea-ice:2) +!>\param dz layer thickness (km) +!>\param delp model layer pressure thickness in mb (100Pa) !>\param ntrac number of tracers minus one (Model%ntrac-1) !>\param ntcw tracer index for cloud liquid water minus one (Model%ntcw-1) !>\param ntiw tracer index for cloud ice water minus one (Model%ntiw-1) @@ -2037,6 +2046,7 @@ end subroutine progcld4 !>\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl !>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops !>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases +!>\param de_lgth clouds decorrelation length (km) !>\section gen_progcld4o progcld4o General Algorithm !! @{ subroutine progcld4o & @@ -2677,9 +2687,8 @@ end subroutine progcld5 !!\param plvl (IX,NLP1), model level pressure in mb (100Pa) !!\param tlyr (IX,NLAY), model layer mean temperature in K !!\param tvly (IX,NLAY), model layer virtual temperature in K -!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm -!!\param clw (IX,NLAY), layer cloud liquid water amount -!!\param ciw (IX,NLAY), layer cloud ice water amount +!!\param ccnd (IX,NLAY), layer cloud condensate amount +!!\param ncnd number of layer cloud condensate types !!\param xlat (IX), grid latitude in radians, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment !!\param xlon (IX), grid longitude in radians (not used) diff --git a/physics/radlw_main.f b/physics/radlw_main.f index 961f92a78..4d560b7b2 100644 --- a/physics/radlw_main.f +++ b/physics/radlw_main.f @@ -1848,6 +1848,8 @@ end subroutine cldprop !!\param cldf layer cloud fraction !!\param nlay number of model vertical layers !!\param ipseed permute seed for random num generator +!!\param dz layer thickness +!!\param de_lgth layer cloud decorrelation length (km) !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_subcol_gen mcica_subcol General Algorithm !! @{ @@ -2086,7 +2088,7 @@ end subroutine mcica_subcol !! 4-h2o/ch4,5-n2o/co2,6-o3/co2 !!\n (:,:,n)n=1,2: the rates of ref press at !! the 2 sides of the layer -!!\param facij factors multiply the reference ks, i,j=0/1 for +!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j=0/1 for !! lower/higher of the 2 appropriate temperatures !! and altitudes. !!\param selffac scale factor for w. v. self-continuum equals @@ -2102,8 +2104,7 @@ end subroutine mcica_subcol !!\param scaleminor,scaleminorn2 scale factors for minor gases !!\param indminor index of lower ref temp for minor gases !>\section setcoef_gen setcoef General Algorithm -!! -! ---------------------------------- +!> @{ subroutine setcoef & & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & ! --- inputs: & nlay, nlp1, & @@ -2360,6 +2361,7 @@ subroutine setcoef & return ! .................................. end subroutine setcoef +!> @} ! ---------------------------------- !>\ingroup module_radlw_main @@ -3768,7 +3770,7 @@ end subroutine rtrnmc !! 5-n2o/co2,6-o3/co2 !!\n (:,:,n)n=1,2: the rates of ref press at the 2 !! sides of the layer -!!\param facij factors multiply the reference ks, i,j of 0/1 +!!\param fac00,fac01,fac10,fac11 factors multiply the reference ks, i,j of 0/1 !! for lower/higher of the 2 appropriate !! temperatures and altitudes !!\param jp index of lower reference pressure diff --git a/physics/radsw_main.f b/physics/radsw_main.f index 628450e06..23bfdaa8a 100644 --- a/physics/radsw_main.f +++ b/physics/radsw_main.f @@ -1586,6 +1586,8 @@ end subroutine rswinit !!\param nlay vertical layer number !!\param ipseed permutation seed for generating random numbers !! (isubcsw>0) +!!\param dz layer thickness (km) +!!\param delgth layer cloud decorrelation length (km) !!\param taucw cloud optical depth, w/o delta scaled !!\param ssacw weighted cloud single scattering albedo !! (ssa = ssacw / taucw) @@ -1974,9 +1976,11 @@ end subroutine cldprop !!\param cldf layer cloud fraction !!\param nlay number of model vertical layers !!\param ipseed permute seed for random num generator +!!\param dz layer thickness (km) +!!\param de_lgth layer cloud decorrelation length (km) !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_sw_gen mcica_subcol General Algorithm -!! @{ +!> @{ ! ---------------------------------- subroutine mcica_subcol & & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs @@ -2184,7 +2188,7 @@ subroutine mcica_subcol & return ! .................................. end subroutine mcica_subcol -!! @} +!> @} ! ---------------------------------- !>\ingroup module_radsw_main @@ -2199,7 +2203,7 @@ end subroutine mcica_subcol !!\param jp indices of lower reference pressure !!\param jt,jt1 indices of lower reference temperatures at !! levels of jp and jp+1 -!!\param facij factors mltiply the reference ks,i,j=0/1 for +!!\param fac00,fac01,fac10,fac11 factors mltiply the reference ks,i,j=0/1 for !! lower/higher of the 2 appropriate temperature !! and altitudes. !!\param selffac scale factor for w. v. self-continuum equals @@ -4004,7 +4008,7 @@ end subroutine vrtqdr !! are for h2o, co2, o3, n2o, ch4, and o2, !! respectively \f$(mol/cm^2)\f$ !!\param colmol total column amount (dry air+water vapor) -!!\param facij for each layer, these are factors that are +!!\param fac00,fac01,fac10,fac11 for each layer, these are factors that are !! needed to compute the interpolation factors !! that multiply the appropriate reference !! k-values. a value of 0/1 for i,j indicates diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 0dc7cc0ee..9c0e9d915 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -448,7 +448,6 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & ! !> - Compute an empirical cloud fraction based on !! Xu and Randall (1996) \cite xu_and_randall_1996 -!! (see \ref cld_fra). do k = 1, km do i = 1, im plyr(i,k) = 0.01 * prsl(i,k) ! pa to mb (hpa) diff --git a/physics/sflx.f b/physics/sflx.f index 926115f13..c41334c91 100644 --- a/physics/sflx.f +++ b/physics/sflx.f @@ -57,6 +57,7 @@ !!\param[in] snoalb real, max albedo over deep snow (fraction) !!\param[in] bexpp real, perturbation of soil type "b" parameter (perturbation) !!\param[in] xlaip real, perturbation of leave area index (perturbation) +!!\param[in] lheatstrg logical, flag for canopy heat storage parameterization !!\param[in,out] tbot real, bottom soil temp (\f$K\f$) (local yearly-mean sfc air temp) !!\param[in,out] cmc real, canopy moisture content (\f$m\f$) !!\param[in,out] t1 real, ground/canopy/snowpack eff skin temp (\f$K\f$) @@ -440,7 +441,7 @@ subroutine gfssflx &! --- input ! --- ... bexp sfc-perts, mgehne !> - Calculate perturbated soil type "b" parameter. -!! Following Gehne et al. (2018) \cite gehne_et_al_2018, a perturbation of LAI +!! Following Gehne et al. (2019) \cite Gehne_2019 , a perturbation of LAI !! "leaf area index" (xlaip) and a perturbation of the empirical exponent parameter !! b in the soil hydraulic conductivity calculation (bexpp) are added to account for !! the uncertainties of LAI and b associated with different vegetation types and soil From 42b442a0c2b2a3403a1ff5602972aaa4bde984a1 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Fri, 14 Jun 2019 09:29:00 -0600 Subject: [PATCH 09/19] scidoc update --- physics/cu_gf_deep.F90 | 1 + physics/cu_gf_driver.F90 | 3 ++ physics/cu_gf_sh.F90 | 26 ++++++---- physics/docs/library.bib | 22 +++++++- physics/docs/pdftxt/GSD_CU_GF_deep.txt | 46 +++++++++-------- physics/docs/pdftxt/suite_input.nml.txt | 6 +-- physics/funcphys.f90 | 68 ++++++++++++------------- physics/micro_mg3_0.F90 | 4 +- physics/module_bl_mynn.F90 | 10 ++-- 9 files changed, 110 insertions(+), 76 deletions(-) diff --git a/physics/cu_gf_deep.F90 b/physics/cu_gf_deep.F90 index 24d57ca8c..4c357d787 100644 --- a/physics/cu_gf_deep.F90 +++ b/physics/cu_gf_deep.F90 @@ -3,6 +3,7 @@ !>\defgroup cu_gf_deep_group Grell-Freitas Deep Convection Module !>\ingroup cu_gf_group +!! This is Grell-Freitas deep convection scheme module module cu_gf_deep use machine , only : kind_phys real(kind=kind_phys), parameter::g=9.81 diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index 2695ace2d..cdd7855d0 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -1,6 +1,7 @@ !>\file cu_gf_driver.F90 !! This file is scale-aware Grell-Freitas cumulus scheme driver. + module cu_gf_driver ! DH* TODO: replace constants with arguments to cu_gf_driver_run @@ -63,8 +64,10 @@ end subroutine cu_gf_driver_finalize !=================== !> \defgroup cu_gf_group Grell-Freitas Convection Scheme Module +!! This is the Grell-Freitas scale and aerosol aware scheme. !>\defgroup cu_gf_driver Grell-Freitas Convection Scheme Driver Module !> \ingroup cu_gf_group +!! This is the Grell-Freitas convection scheme driver module. !! \section arg_table_cu_gf_driver_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |----------------|-----------------------------------------------------------|-----------------------------------------------------|---------------|------|-----------|-----------|--------|----------| diff --git a/physics/cu_gf_sh.F90 b/physics/cu_gf_sh.F90 index 5eb582f2d..7f88d0c14 100644 --- a/physics/cu_gf_sh.F90 +++ b/physics/cu_gf_sh.F90 @@ -1,5 +1,5 @@ !>\file cu_gf_sh.F90 -!! This file contains +!! This file contains Grell-Freitas shallow convection scheme. !>\defgroup cu_gf_sh_group Grell-Freitas Shallow Convection Module !> \ingroup cu_gf_group @@ -30,6 +30,7 @@ module cu_gf_sh !!\param dhdt forcing for boundary layer equilibrium !!\param hfx,qfx in w/m2 (positive, if upward from sfc) !!\param kpbl level of boundaty layer height +!!\param rho moist air density !!\param xland land mask (1. for land) !!\param ichoice which closure to choose !!\n 1: old g @@ -37,6 +38,7 @@ module cu_gf_sh !!\n 3: dhdt !!\n 0: average !!\param tcrit parameter for water/ice conversion (258) +!!\param dtime physics time step !!\param zuo normalized mass flux profile !!\param xmb_out base mass flux !!\param kbcon convective cloud base @@ -47,10 +49,12 @@ module cu_gf_sh !!\param outt temperature tendency (k/s) !!\param outq mixing ratio tendency (kg/kg/s) !!\param outqc cloud water/ice tendency (kg/kg/s) +!!\param outu x wind tendency +!!\param outv y wind tendency !!\param pre precip rate (mm/s) !!\param cupclw incloud mixing ratio of cloudwater/ice (for radiation) !! this needs heavy tuning factors, since cloud fraction is -!! not included (kg/kg) +!! not included (kg/kg) !!\param cnvwt required for gfs physics !!\param itf,ktf,its,ite, kts,kte are dimensions !!\param ipr horizontal index of printed column @@ -290,11 +294,11 @@ subroutine cu_gf_sh_run ( & enddo ! -!--- max height(m) above ground where updraft air can originate +!> - Determin max height(m) above ground where updraft air can originate ! zkbmax=3000. ! -!--- calculate moist static energy, heights, qes +!> - Call cup_env() to calculate moist static energy, heights, qes ! call cup_env(z,qes,he,hes,t,q,po,z1, & psur,ierr,tcrit,-1, & @@ -306,7 +310,7 @@ subroutine cu_gf_sh_run ( & its,ite, kts,kte) ! -!--- environmental values on cloud levels +!> - Call cup_env_clev() to calculate environmental values on cloud levels ! call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, & hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, & @@ -347,7 +351,7 @@ subroutine cu_gf_sh_run ( & ! ! ! -!------- determine level with highest moist static energy content - k22 +!> - Determine level with highest moist static energy content (\p k22) ! do 36 i=its,itf if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i)) @@ -364,7 +368,8 @@ subroutine cu_gf_sh_run ( & endif 36 continue ! -!--- determine the level of convective cloud base - kbcon +!> - Call get_cloud_bc() and cup_kbcon() to determine the level of +!! convective cloud base (\p kbcon) ! do i=its,itf if(ierr(i).eq.0)then @@ -388,7 +393,8 @@ subroutine cu_gf_sh_run ( & 0,itf,ktf, & its,ite, kts,kte, & z_cup,entr_rate,heo,0) -!--- get inversion layers for cloud tops + +!> - Call cup_minimi() and get_inversion_layers() to get inversion layers for cloud tops call cup_minimi(heso_cup,kbcon,kbmax,kstabi,ierr, & itf,ktf, & its,ite, kts,kte) @@ -432,7 +438,7 @@ subroutine cu_gf_sh_run ( & endif endif enddo -! get normalized mass flux profile +!> - Call rates_up_pdf() to get normalized mass flux profile call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, & xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,kbcon,pmin_lev) do i=its,itf @@ -470,7 +476,7 @@ subroutine cu_gf_sh_run ( & endif enddo ! -! calculate mass entrainment and detrainment +!> - Call get_lateral_massflux() to calculate mass entrainment and detrainment ! call get_lateral_massflux(itf,ktf, its,ite, kts,kte & ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d & diff --git a/physics/docs/library.bib b/physics/docs/library.bib index 5775c6b7b..223c34395 100644 --- a/physics/docs/library.bib +++ b/physics/docs/library.bib @@ -1,13 +1,33 @@ %% This BibTeX bibliography file was created using BibDesk. %% http://bibdesk.sourceforge.net/ -%% Created for Man Zhang at 2019-06-10 16:42:57 -0600 +%% Created for Man Zhang at 2019-06-13 14:38:54 -0600 %% Saved with string encoding Unicode (UTF-8) +@article{bechtold_et_al_2014, + Author = {P. Bechtold and N. Semane and P. Lopez and J-P Chaboureau and A. Beljaars and N. Bormann}, + Date-Added = {2019-06-13 14:29:21 -0600}, + Date-Modified = {2019-06-13 14:38:38 -0600}, + Journal = {J. Atmos. Sci.}, + Pages = {734-753}, + Title = {Representing equilibrium and nonequilibrium convection in large-scale models}, + Volume = {71}, + Year = {2014}} + +@article{freitas_et_al_2018, + Author = {S.R. Freitas and G.A. Grell and A. Molod and M. A. Thompson and W.M. Putman and C. M. Santos e Silva and E. P. Souza}, + Date-Added = {2019-06-13 13:51:50 -0600}, + Date-Modified = {2019-06-13 14:07:37 -0600}, + Journal = {Journal of Advances in Modeling Earth Systems}, + Pages = {1266-1289}, + Title = {Assessing the Grell-Freitas convection parameterization in the NASA GEOS modeling system}, + Volume = {10}, + Year = {2018}} + @article{qu_and_hall_2005, Author = {X. Qu and A. Hall}, Date-Added = {2019-06-10 16:41:01 -0600}, diff --git a/physics/docs/pdftxt/GSD_CU_GF_deep.txt b/physics/docs/pdftxt/GSD_CU_GF_deep.txt index 041e92692..05e3cf39e 100644 --- a/physics/docs/pdftxt/GSD_CU_GF_deep.txt +++ b/physics/docs/pdftxt/GSD_CU_GF_deep.txt @@ -2,31 +2,33 @@ \page GSD_CU_GF Grell-Freitas Scale and Aerosol Aware Convection Scheme \section gfcu_descrip Description -The Grell-Freitas scale and aerosol aware convection scheme is an Arakawa-Schubert mass flux type scheme, and is both aerosol and scale aware. -Aerosol awareness (emulating the impact of aerosols on precipitation processes) is obtained through changing the rate of -conversion from cloud droplets to raindrops (Berry (1968) \cite berry_1968 ), and by modifying the precipitation efficiency of the -raindrops (the fraction of total condensed water volume in the cloud's lifetime reaching the ground (Jiang et al. (2010) \cite Jiang_2010) ) -Scale awareness comes through the use of an empirical formula for the fractional area (\f$\sigma\f$) of the model grid column -containing updrafts and downdrafts (Arakawa et al. (2011) \cite Arakawa_2011 ). The entrainment rate for the updrafts is an inverse function -of \f$\sigma\f$. As the fractional coverage become large, the resolved motion takes over convective processes -and the Grell-Freitas scheme becomes a shallow convection scheme, simulating the effects of unresolved fair weather -and towering cumulus on the forecast variables. - -The GF scheme uses an ensemble of convective schemes, with options that modulate closure and capping -inversion thresholds for convection. After calculations for each member of the cloud ensemble in the convective scheme, the ensemble -mean time tendency for temperature, moisture, and cloud and precipitation hydrometeors is passed to the rest of the model -(Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 ). Additionally, the upward mass flux from parameterized convective updrafts is balanced by -subsidence in adjacent grid columns, if the horizontal grid spacing of the model using the parameterization is less than 10 km. - -# Operational Impacts in RAP/HRRR +The Grell-Freitas (GF) scheme as described in Grell and Freitas (2014, GF1) \cite grell_and_freitas_2014 and +Freitas et al. (2018, FG) \cite freitas_et_al_2018 follow the mass flux approach published by Grell (1993) \cite grell_1993. +Further developments by Grell and \f$D\acute{e}v\acute{e}nyi\f$ (2002) \cite Grell_2002 included implementing +stochastics through allowing parameter perturbations. In GF1 scale awareness, and the aerosol dependence through rain generation (following +Berry (1968) \cite berry_1968 and evaporation formulations (following Jiang et al. (2010) \cite Jiang_2010 ), depending on the +cloud concentration nuclei at cloud base were added. FG included mixed phase physics impact, momentum transport (as in ECMWF), + a diurnal cycle closure (Bechtold et al. (2014) \cite bechtold_et_al_2014 ), and a trimodal spectral size to simulate the interaction +and transition from shallow, congestus and deep convection regimes. The vertical massflux distribution of shallow, congestus and +deep convection regimes is characterized by Probability Density Functions (PDF's). The three PDF's are meant to represent the average +statistical mass flux characteristic of deep, congestus, and shallow (respectively) plumes in the grid area. Each PDF therefore represents +a spectrum of plumes within the grid box. Forcing is different for each characteristic type. Entrainment and detrainment are derived +from the PDF's. The deep convection considers scale awareness (Arakawa et al. (2011) \cite Arakawa_2011 ), the congestus type convection +as well as the shallow convection are not scale-aware. Aerosol dependence is implemented through dependence of rain generation and +evaporation formulations depending on the cloud concentration nuclei at cloud base. Aerosol dependence is considered experimental and +is turned off at this point. GF is able to transport tracers. + +A paper describing the latest changes and modifications is in progress and will be submitted to GMD. + +\b Operational \b Impacts \b in \b RAP/HRRR - Uses mass-flux schemes, which are more physically realistic than (sounding) adjustment schemes - - Takes parameterization uncertainty into account by using multiple convective schemes, using variations on scheme parameters - - For higher resolutions (less than 10 km), transitions as grid spacing decreases into a shallow convection scheme, as the grid scale motions begin to handle convective processes. This makes the scheme "scale aware". - - Scheme is aerosol-aware, driven by aerosol relationship to concentration of condensation nuclei. + - Takes parameterization uncertainty into account by allowing parameters from multiple convective schemes which can be perturbed +internally or with temporal and spatial correlation patterns + - For higher resolutions (less than 10 km), in addition to scale awareness as in Arakawa et al. (2011) \cite Arakawa_2011 GF can +transition as grid spacing decreases into a shallow convection scheme - Coupled to the grid scale precipitation and radiation schemes through passing of diagnosed cloud liquid and ice from simulated -precipitating convective cloud and shallow convective clouds, - +precipitating convective cloud and shallow convective clouds \section intra_rough_gf Intraphysics Communication The GF scheme passes cloud hydrometeors to the grid-scale microphysics scheme (\ref GSD_THOMPSON ) through detrainment from each diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index a9b6734ed..8817d5590 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -6,13 +6,13 @@ various namelists that control aspects of the I/O, dynamics, physics etc. Most p two namelists:\b &gfs_physics_nml and \b &gfdl_cloud_microphysics_nml, with additional specifications for stochastic physics in namelists \b &stochy_nam and \b &nam_sfcperts. -Namelist \b &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in +- Namelist \b &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in module_gfdl_cloud_microphys.F90. -Namelist \b &gfs_physics_nml pertains to all of the suites used, but some of the variables are only relevant for specific +- Namelist \b &gfs_physics_nml pertains to all of the suites used, but some of the variables are only relevant for specific parameterizations. Its variables are defined in file GFS_typedefs.F90 in the host model. -Namelist \b &stochy_nam specifies options for the use of SPPT, SKEB and SHUM, while namelist \b &nam_sfcperts specifies whether +- Namelist \b &stochy_nam specifies options for the use of SPPT, SKEB and SHUM, while namelist \b &nam_sfcperts specifies whether and how stochastic perturbations are used in the Noah Land Surface Model.
diff --git a/physics/funcphys.f90 b/physics/funcphys.f90 index 950698c97..8cb4b1b15 100644 --- a/physics/funcphys.f90 +++ b/physics/funcphys.f90 @@ -471,7 +471,7 @@ elemental function fpvslq(t) !! This function should be expanded inline in the calling routine. !>\author N Phillips !>\param[in] t real, temperature in Kelvin -!>\param[out] fpvslx real, saturation vapor pressure in Pascals +!\param[out] fpvslx real, saturation vapor pressure in Pascals elemental function fpvslx(t) !$$$ Subprogram Documentation Block ! @@ -683,7 +683,7 @@ elemental function fpvsiq(t) !!\n where tr is ttp/t and other values are physical constants. !! This function should be expanded inline in the calling routine. !>\param[in] t real, temperature in Kelvin -!>\param[out] fpvsix real, saturation vapor pressure in Pascals +!\param[out] fpvsix real, saturation vapor pressure in Pascals elemental function fpvsix(t) !$$$ Subprogram Documentation Block ! @@ -902,8 +902,8 @@ elemental function fpvsq(t) !!\n where tr is ttp/t and other values are physical constants. !! The reference for this computation is Emanuel(1994), pages 116-117. !! This function should be expanded inline in the calling routine. -!>\param[in] t real, temperature in Kelvin -!>\param[out] fpvsx real, saturation vapor pressure in Pascals +!!\param[in] t real, temperature in Kelvin +!\param[out] fpvsx real, saturation vapor pressure in Pascals elemental function fpvsx(t) !$$$ Subprogram Documentation Block ! @@ -1078,8 +1078,8 @@ elemental function ftdpl(pv) !! A quadratic interpolation is done between values in a lookup table !! computed in gtdpl(). See documentation for ftdplxg() for details. !! Input values outside table range are reset to table extrema. -!>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdplq real, dewpoint temperature in Kelvin +!!\param[in] pv real, vapor pressure in Pascals +!\param[out] ftdplq real, dewpoint temperature in Kelvin elemental function ftdplq(pv) !$$$ Subprogram Documentation Block ! @@ -1133,8 +1133,8 @@ elemental function ftdplq(pv) !! An approximate dewpoint temperature for function ftdplxg() !! is obtained using ftdpl() so gtdpl() must be already called. !! See documentation for ftdplxg() for details. -!>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdplx real, dewpoint temperature in Kelvin +!!\param[in] pv real, vapor pressure in Pascals +!\param[out] ftdplx real, dewpoint temperature in Kelvin elemental function ftdplx(pv) !$$$ Subprogram Documentation Block ! @@ -1190,9 +1190,9 @@ elemental function ftdplx(pv) !!\n The formula is inverted by iterating Newtonian approximations !! for each pvs until t is found to within 1.e-6 Kelvin. !! This function can be expanded inline in the calling routine. -!>\param[in] tg real, guess dewpoint temperature in Kelvin -!>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdplxg real, dewpoint temperature in Kelvin +!!\param[in] tg real, guess dewpoint temperature in Kelvin +!!\param[in] pv real, vapor pressure in Pascals +!\param[out] ftdplxg real, dewpoint temperature in Kelvin elemental function ftdplxg(tg,pv) !$$$ Subprogram Documentation Block ! @@ -1314,7 +1314,7 @@ subroutine gtdpi !! computed in gtdpi(). See documentation for ftdpixg for details. !! Input values outside table range are reset to table extrema. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpi real, dewpoint temperature in Kelvin +!\param[out] ftdpi real, dewpoint temperature in Kelvin elemental function ftdpi(pv) !$$$ Subprogram Documentation Block ! @@ -1366,7 +1366,7 @@ elemental function ftdpi(pv) !! computed in gtdpi(). see documentation for ftdpixg() for details. !! Input values outside table range are reset to table extrema. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpiq real, dewpoint temperature in Kelvin +!\param[out] ftdpiq real, dewpoint temperature in Kelvin elemental function ftdpiq(pv) !$$$ Subprogram Documentation Block ! @@ -1422,7 +1422,7 @@ elemental function ftdpiq(pv) !! is obtained using ftdpi() so gtdpi() must be already called. !! See documentation for ftdpixg() for details. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpix real, dewpoint temperature in Kelvin +!\param[out] ftdpix real, dewpoint temperature in Kelvin elemental function ftdpix(pv) !$$$ Subprogram Documentation Block ! @@ -1481,7 +1481,7 @@ elemental function ftdpix(pv) !! This function can be expanded inline in the calling routine. !>\param[in] tg real, guess dewpoint temperature in Kelvin !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpixg real, dewpoint temperature in Kelvin +!\param[out] ftdpixg real, dewpoint temperature in Kelvin elemental function ftdpixg(tg,pv) !$$$ Subprogram Documentation Block ! @@ -1604,7 +1604,7 @@ subroutine gtdp !! computed in gtdp(). See documentation for ftdpxg() for details. !! Input values outside table range are reset to table extrema. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdp real, dewpoint temperature in Kelvin +!\param[out] ftdp real, dewpoint temperature in Kelvin elemental function ftdp(pv) !$$$ Subprogram Documentation Block ! @@ -1656,7 +1656,7 @@ elemental function ftdp(pv) !! computed in gtdp(). See documentation for ftdpxg() for details. !! Input values outside table range are reset to table extrema. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpq real, dewpoint temperature in Kelvin +!\param[out] ftdpq real, dewpoint temperature in Kelvin elemental function ftdpq(pv) !$$$ Subprogram Documentation Block ! @@ -1712,7 +1712,7 @@ elemental function ftdpq(pv) !! is obtained using ftdp() so gtdp() must be already called. !! See documentation for ftdpxg() for details. !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpx real, dewpoint temperature in Kelvin +!\param[out] ftdpx real, dewpoint temperature in Kelvin elemental function ftdpx(pv) !$$$ Subprogram Documentation Block ! @@ -1776,7 +1776,7 @@ elemental function ftdpx(pv) !! This function can be expanded inline in the calling routine. !>\param[in] tg real, guess dewpoint temperature in Kelvin !>\param[in] pv real, vapor pressure in Pascals -!>\param[out] ftdpxg real, dewpoint temperature in Kelvin +!\param[out] ftdpxg real, dewpoint temperature in Kelvin elemental function ftdpxg(tg,pv) !$$$ Subprogram Documentation Block ! @@ -1937,7 +1937,7 @@ subroutine gthe !! except zero is returned for too cold or high LCLs. !>\param[in] t real, LCL temperature in Kelvin !>\param[in] pk real, LCL pressure over 1e5 Pa to the kappa power -!>\param[out] fthe real, equivalent potential temperature in Kelvin +!\param[out] fthe real, equivalent potential temperature in Kelvin elemental function fthe(t,pk) !$$$ Subprogram Documentation Block ! @@ -2000,7 +2000,7 @@ elemental function fthe(t,pk) !! except zero is returned for too cold or high LCLs. !>\param[in] t real, LCL temperature in Kelvin !>\param[in] pk real, LCL pressure over 1e5 Pa to the kappa power -!>\param[out] ftheq real, equivalent potential temperature in Kelvin +!\param[out] ftheq real, equivalent potential temperature in Kelvin elemental function ftheq(t,pk) !$$$ Subprogram Documentation Block ! @@ -2085,7 +2085,7 @@ elemental function ftheq(t,pk) !! This function should be expanded inline in the calling routine. !>\param[in] t real, LCL temperature in Kelvin !>\param[in] pk real, LCL pressure over 1e5 Pa to the kappa power -!>\param[out] fthex real, equivalent potential temperature in Kelvin +!\param[out] fthex real, equivalent potential temperature in Kelvin function fthex(t,pk) !$$$ Subprogram Documentation Block ! @@ -2283,7 +2283,7 @@ elemental subroutine stma(the,pk,tma,qma) !! Input values outside table range are reset to table extrema. !>\param[in] the real, equivalent potential temperature in Kelvin !>\param[in] pk real, pressure over 1e5 Pa to the kappa power -!>\param[out] tmaq real, parcel temperature in Kelvin +!>\param[out] tma real, parcel temperature in Kelvin !>\param[out] qma real, parcel specific humidity in kg/kg elemental subroutine stmaq(the,pk,tma,qma) !$$$ Subprogram Documentation Block @@ -2569,7 +2569,7 @@ subroutine gpkap !! computed in gpkap(). See documentation for fpkapx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] p real, pressure in Pascals -!>\param[out] fpkap real, p over 1e5 Pa to the kappa power +!\param[out] fpkap real, p over 1e5 Pa to the kappa power elemental function fpkap(p) !$$$ Subprogram Documentation Block ! @@ -2621,7 +2621,7 @@ elemental function fpkap(p) !! computed in gpkap(). see documentation for fpkapx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] p real, pressure in Pascals -!>\param[out] fpkapq real, p over 1e5 Pa to the kappa power +!\param[out] fpkapq real, p over 1e5 Pa to the kappa power elemental function fpkapq(p) !$$$ Subprogram Documentation Block ! @@ -2678,7 +2678,7 @@ elemental function fpkapq(p) !! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx(). !>\param[in] p real, surface pressure in Pascals p should be in the !! range 40000 to 110000 -!>\param[out] fpkapo real, p over 1e5 Pa to the kappa power +!\param[out] fpkapo real, p over 1e5 Pa to the kappa power function fpkapo(p) !$$$ Subprogram documentation block ! @@ -2739,7 +2739,7 @@ function fpkapo(p) !> This function raises pressure over 1e5 Pa to the kappa power. !! Kappa is equal to rd/cp where rd and cp are physical constants. !>\param[in] p real, pressure in Pascals -!>\param[out] fpkapx real, p over 1e5 Pa to the kappa power +!\param[out] fpkapx real, p over 1e5 Pa to the kappa power elemental function fpkapx(p) !$$$ Subprogram documentation block ! @@ -2827,7 +2827,7 @@ subroutine grkap !! computed in grkap(). See documentation for frkapx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] pkap real, p over 1e5 Pa to the kappa power -!>\param[out] frkap real, pressure in Pascals +!\param[out] frkap real, pressure in Pascals elemental function frkap(pkap) !$$$ Subprogram Documentation Block ! @@ -2878,7 +2878,7 @@ elemental function frkap(pkap) !! computed in grkap(). see documentation for frkapx() for details. !! Input values outside table range are reset to table extrema. !>\param[in] pkap real, p over 1e5 Pa to the kappa power -!>\param[out] frkapq real, pressure in Pascals +!\param[out] frkapq real, pressure in Pascals elemental function frkapq(pkap) !$$$ Subprogram Documentation Block ! @@ -2931,7 +2931,7 @@ elemental function frkapq(pkap) !> This function raise pressure over 1e5 Pa to the 1/kappa power. !! Kappa is equal to rd/cp where rd and cp are physical constants. !>\param[in] pkap real, p over 1e5 Pa to the kappa power -!>\param[out] frkapx real, pressure in Pascals +!\param[out] frkapx real, pressure in Pascals elemental function frkapx(pkap) !$$$ Subprogram documentation block ! @@ -3032,7 +3032,7 @@ subroutine gtlcl !! Input values outside table range are reset to table extrema. !>\param[in] t real, LCL temperature in Kelvin !>\param[in] tdpd real, dewpoint depression in Kelvin -!>\param[out] ftlcl real, temperature at the LCL in Kelvin +!\param[out] ftlcl real, temperature at the LCL in Kelvin elemental function ftlcl(t,tdpd) !$$$ Subprogram Documentation Block ! @@ -3087,7 +3087,7 @@ elemental function ftlcl(t,tdpd) !! Input values outside table range are reset to table extrema. !>\param[in] t real, LCL temperature in Kelvin !>\param[in] tdpd real, dowpoint depression in Kelvin -!>\param[out] ftlcl real, temperature at the LCL in Kelvin +!\param[out] ftlcl real, temperature at the LCL in Kelvin elemental function ftlclq(t,tdpd) !$$$ Subprogram Documentation Block ! @@ -3155,7 +3155,7 @@ elemental function ftlclq(t,tdpd) !! approximates the original exact implicit relationship. !>\param[in] t real, temperature in Kelvin !>\param[in] tdpd real, dewpoint depression in Kelvin -!>\param[out] ftlclo real, temperature at the LCL in Kelvin +!\param[out] ftlclo real, temperature at the LCL in Kelvin function ftlclo(t,tdpd) !$$$ Subprogram documentation block ! @@ -3219,7 +3219,7 @@ function ftlclo(t,tdpd) !! returned temperature is 180 Kelvin. !>\param[in] t real, temperature in Kelvin !>\param[in] tdpd real, dewpoint depression in Kelvin -!>\param[out] ftlclx real, temperature at the LCL in Kelvin +!\param[out] ftlclx real, temperature at the LCL in Kelvin elemental function ftlclx(t,tdpd) !$$$ Subprogram documentation block ! diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 671290749..d9d47a347 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -582,7 +582,9 @@ subroutine micro_mg_tend ( & real(r8), intent(in) :: liqcldf(mgncol,nlev) !< liquid cloud fraction (no units) real(r8), intent(in) :: icecldf(mgncol,nlev) !< ice cloud fraction (no units) real(r8), intent(in) :: qsatfac(mgncol,nlev) !< subgrid cloud water saturation scaling factor (no units) - logical, intent(in) :: lprnt, iccn, aero_in + logical, intent(in) :: lprnt !< control flag for diagnostic print out + logical, intent(in) :: iccn !< flag for IN and CCN forcing for Morrison-Gettelman microphysics + logical, intent(in) :: aero_in !< flag for using aerosols in Morrison-Gettelman microphysics ! used for scavenging diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 44a5156c1..183d4bb5a 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -1134,12 +1134,12 @@ END SUBROUTINE mym_length !! computational expense. This subroutine computes the length scales up and down !! and then computes the min, average of the up/down length scales, and also !! considers the distance to the surface. -!!\param dlu the distance a parcel can be lifted upwards give a finite -!! amount of TKE. +!\param dlu the distance a parcel can be lifted upwards give a finite +! amount of TKE. !\param dld the distance a parcel can be displaced downwards given a -!! finite amount of TKE. -!!\param lb1 the minimum of the length up and length down -!!\param lb2 the average of the length up and length down +! finite amount of TKE. +!\param lb1 the minimum of the length up and length down +!\param lb2 the average of the length up and length down SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) INTEGER, INTENT(IN) :: k,kts,kte From 611930c00bd87a687e4611a28d55451752378ffb Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Fri, 14 Jun 2019 09:44:58 -0600 Subject: [PATCH 10/19] scidoc update --- physics/docs/pdftxt/suite_input.nml.txt | 28 ++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index 8817d5590..bc904bfac 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -181,7 +181,7 @@ and how stochastic perturbations are used in the Noah Land Surface Model.
  • 1:July 2010 version of mass-flux shallow convective scheme (operational as of 2016)
  • 2: scale- & aerosol-aware mass-flux shallow convective scheme (2017)
  • 3: scale- & aerosol-aware Grell-Freitas scheme (GSD) -
  • 4: New Tiedtke scheme (CAPS) +
  • 4: new Tiedtke scheme (CAPS)
  • 0: modified Tiedtke's eddy-diffusion shallow convective scheme
  • -1: no shallow convection used @@ -191,7 +191,7 @@ and how stochastic perturbations are used in the Noah Land Surface Model.
  • 1: July 2010 version of SAS convective scheme (operational version as of 2016)
  • 2: scale- & aerosol-aware mass-flux deep convective scheme (2017)
  • 3: scale- & aerosol-aware Grell-Freitas scheme (GSD) -
  • 4: New Tiedtke scheme (CAPS) +
  • 4: new Tiedtke scheme (CAPS)
    • 1
    lgfdlmprad gfs_control_type flag for GFDL mp scheme and radiation consistency .false. @@ -294,27 +294,27 @@ and how stochastic perturbations are used in the Noah Land Surface Model. 2
    bl_mynn_edmf gfs_control_type flag to activate the mass-flux scheme \n
      -
    • 0: Deactivate mass-flux scheme -
    • 1: Activate dynamic multiplume mass-flux scheme +
    • 0: deactivate mass-flux scheme +
    • 1: activate dynamic multiplume mass-flux scheme
    		0
    bl_mynn_edmf_mom gfs_control_type flag to activate the transport of momentum \n
      -
    • 0: Deactivate momentum transport in mass-flux scheme -
    • 1: Activate momentum transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 +
    • 0: deactivate momentum transport in mass-flux scheme +
    • 1: activate momentum transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1
    		1
    bl_mynn_edmf_tke gfs_control_type flag to activate the transport of TKE \n
      -
    • 0: Deactivate TKE transport in mass-flux scheme -
    • 1: Activate TKE transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1 +
    • 0: deactivate TKE transport in mass-flux scheme +
    • 1: activate TKE transport in dynamic multiplume mass-flux scheme. \p bl_mynn_edmf must be set to 1
    		0
    bl_mynn_edmf_part gfs_control_type flag to partitioning the MF and ED areas 0
    bl_mynn_edmf_tkeadvect gfs_control_type activate computation of TKE advection (not yet in use for FV3) \n
      -
    • False: Deactivate TKE advection -
    • True: Activate TKE advection +
    • false: deactivate TKE advection +
    • true: activate TKE advection
    		.false.
    bl_mynn_edmf_tkebudget gfs_control_type flag to activate TKE budget 0 @@ -327,20 +327,20 @@ and how stochastic perturbations are used in the Noah Land Surface Model. 2
    bl_mynn_edmf_cloudmix gfs_control_type flag to activate mixing of cloud species \n
      -
    • 0: Deactivate the mixing of any water species mixing ratios +
    • 0: deactivate the mixing of any water species mixing ratios
    • 1: activate the mixing of all water species mixing ratios
    		1
    bl_mynn_mixqt gfs_control_type flag to mix total water or individual species \n
      -
    • 0: Mix individual water species separately +
    • 0: mix individual water species separately
    • 1: DO NOT USE
    		0
    icloud_bl gfs_control_type flag to coupling SGS clouds to radiation \n
      -
    • 0: Deactivate coupling subgrid clouds to radiation -
    • 1: Activate subgrid cloud coupling to radiation (highly suggested) +
    • 0: deactivate coupling subgrid clouds to radiation +
    • 1: activate subgrid cloud coupling to radiation (highly suggested)
    		1
    lsoil_lsm gfs_control_type number of soil layers internal to land surface model -1 From 170a31569f6d8965f6a5917666188dad33d0581d Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Tue, 18 Jun 2019 10:41:49 -0600 Subject: [PATCH 11/19] doc update --- physics/docs/pdftxt/GFS_SATMEDMF.txt | 2 +- physics/satmedmfvdif.F | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/docs/pdftxt/GFS_SATMEDMF.txt b/physics/docs/pdftxt/GFS_SATMEDMF.txt index 3dd9eb17e..22e73a458 100644 --- a/physics/docs/pdftxt/GFS_SATMEDMF.txt +++ b/physics/docs/pdftxt/GFS_SATMEDMF.txt @@ -8,7 +8,7 @@ counter-gradient(EDCG) scheme is used for the weakly unstable PBL. The new TKE-E -# Eddy diffusivity (K) is now a function of TKE which is prognostically predicted --# EDMF approach is appled for all the unstable PBL +-# EDMF approach is applied for all the unstable PBL -# EDMF approach is also applied to the stratocumulus-top-driven turbulence mixing diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 9c0e9d915..fc3cc9d98 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -286,7 +286,7 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & kmpbl = km / 2 kmscu = km / 2 !> - Compute physical height of the layer centers and interfaces from -!! the geopotential height (zi and zl) +!! the geopotential height (\p zi and \p zl) do k=1,km do i=1,im zi(i,k) = phii(i,k) * gravi @@ -307,12 +307,12 @@ subroutine satmedmfvdif_run(ix,im,km,ntrac,ntcw,ntiw,ntke, & zm(i,k) = zi(i,k+1) enddo enddo -!> - Compute horizontal grid size (gdx) +!> - Compute horizontal grid size (\p gdx) do i=1,im gdx(i) = sqrt(garea(i)) enddo !> - Initialize tke value at vertical layer centers and interfaces -!! from tracer (tke and tkeh) +!! from tracer (\p tke and \p tkeh) do k=1,km do i=1,im tke(i,k) = max(q1(i,k,ntke), tkmin) From 5be49aefed27221b024237f13086c88e0b483728 Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Tue, 18 Jun 2019 15:08:51 -0600 Subject: [PATCH 12/19] restore schemes deleted in CCPP-SCM v3 release --- physics/GFS_phys_time_vary.fv3.F90 | 486 +++ physics/GFS_rad_time_vary.fv3.F90 | 114 + physics/GFS_stochastics.F90 | 249 ++ physics/GFS_suite_init_finalize_test.F90 | 68 + physics/GFS_time_vary_pre.fv3.F90 | 141 + physics/cu_ntiedtke.F90 | 3840 ++++++++++++++++++++++ physics/cu_ntiedtke_post.F90 | 53 + physics/cu_ntiedtke_pre.F90 | 84 + physics/gcm_shoc.F90 | 2040 ++++++++++++ physics/gscond.f | 526 +++ physics/module_MYNNSFC_wrapper.F90 | 362 ++ physics/moninshoc.f | 607 ++++ physics/ozphys.f | 202 ++ physics/precpd.f | 735 +++++ physics/shinhongvdif.F90 | 2106 ++++++++++++ physics/ysuvdif.F90 | 1271 +++++++ 16 files changed, 12884 insertions(+) create mode 100644 physics/GFS_phys_time_vary.fv3.F90 create mode 100644 physics/GFS_rad_time_vary.fv3.F90 create mode 100644 physics/GFS_stochastics.F90 create mode 100644 physics/GFS_suite_init_finalize_test.F90 create mode 100644 physics/GFS_time_vary_pre.fv3.F90 create mode 100644 physics/cu_ntiedtke.F90 create mode 100644 physics/cu_ntiedtke_post.F90 create mode 100644 physics/cu_ntiedtke_pre.F90 create mode 100644 physics/gcm_shoc.F90 create mode 100644 physics/gscond.f create mode 100644 physics/module_MYNNSFC_wrapper.F90 create mode 100644 physics/moninshoc.f create mode 100644 physics/ozphys.f create mode 100644 physics/precpd.f create mode 100644 physics/shinhongvdif.F90 create mode 100644 physics/ysuvdif.F90 diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 new file mode 100644 index 000000000..b8823fac6 --- /dev/null +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -0,0 +1,486 @@ +!> \file GFS_phys_time_vary.fv3.F90 +!! Contains code related to GFS physics suite setup (physics part of time_vary_step) + +!>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update +!! This module contains GFS physics time vary subroutines including ozone, h2o, i +!! aerosol and IN&CCN updates. + module GFS_phys_time_vary + +#ifdef OPENMP + use omp_lib +#endif + + use ozne_def, only : levozp, oz_coeff, oz_lat, oz_pres, oz_time, ozplin + use ozinterp, only : read_o3data, setindxoz, ozinterpol + + use h2o_def, only : levh2o, h2o_coeff, h2o_lat, h2o_pres, h2o_time, h2oplin + use h2ointerp, only : read_h2odata, setindxh2o, h2ointerpol + + use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm + use aerinterp, only : read_aerdata, setindxaer, aerinterpol + + use iccn_def, only : ciplin, ccnin, ci_pres + use iccninterp, only : read_cidata, setindxci, ciinterpol + + implicit none + + private + + public GFS_phys_time_vary_init, GFS_phys_time_vary_run, GFS_phys_time_vary_finalize + + logical :: is_initialized = .false. + + contains + +!> \section arg_table_GFS_phys_time_vary_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | +!! | Interstitial | GFS_interstitial_type_instance_all_threads | Fortran DDT containing FV3-GFS interstitial data | DDT | 1 | GFS_interstitial_type | | inout | F | +!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, errflg) + + use GFS_typedefs, only: GFS_control_type, GFS_data_type, GFS_interstitial_type + + implicit none + + ! Interface variables + type(GFS_data_type), intent(inout) :: Data(:) + type(GFS_control_type), intent(inout) :: Model + type(GFS_interstitial_type), intent(inout) :: Interstitial(:) + integer, intent(in) :: nthrds + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: nb, nblks, nt + integer :: i, j, ix + logical :: non_uniform_blocks + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_initialized) return + + nblks = size(Model%blksz) + + ! Non-uniform blocks require special handling: instead + ! of nthrds elements of the Interstitial array, there are + ! nthrds+1 elements. The extra Interstitial(nthrds+1) is + ! allocated for the smaller block length of the last block, + ! while all other elements are allocated to the maximum + ! block length (which is the same for all blocks except + ! the last block). + if (minval(Model%blksz)==maxval(Model%blksz)) then + non_uniform_blocks = .false. + else + non_uniform_blocks = .true. + end if + + ! Consistency check - number of threads passed in via the argument list + ! has to match the size of the Interstitial data type. + if (.not. non_uniform_blocks .and. nthrds/=size(Interstitial)) then + write(errmsg,'(*(a))') 'Logic error: nthrds does not match size of Interstitial variable' + errflg = 1 + return + else if (non_uniform_blocks .and. nthrds+1/=size(Interstitial)) then + write(errmsg,'(*(a))') 'Logic error: nthrds+1 does not match size of Interstitial variable ' // & + '(including extra last element for shorter blocksizes)' + errflg = 1 + return + end if + +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP private (nt,nb) & +!$OMP shared (Model,Data,Interstitial,errmsg,errflg) & +!$OMP shared (levozp,oz_coeff,oz_pres) & +!$OMP shared (levh2o,h2o_coeff,h2o_pres) & +!$OMP shared (ntrcaer,nblks,nthrds,non_uniform_blocks) + +#ifdef OPENMP + nt = omp_get_thread_num()+1 +#else + nt = 1 +#endif + +!$OMP sections + +!$OMP section + call read_o3data (Model%ntoz, Model%me, Model%master) + + ! Consistency check that the hardcoded values for levozp and + ! oz_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! in GFS_typedefs.F90: allocate (Tbd%ozpl (IM,levozp,oz_coeff)) + if (size(Data(1)%Tbd%ozpl, dim=2).ne.levozp) then + write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + "levozp from read_o3data does not match value in GFS_typedefs.F90: ", & + levozp, " /= ", size(Data(1)%Tbd%ozpl, dim=2) + errflg = 1 + end if + if (size(Data(1)%Tbd%ozpl, dim=3).ne.oz_coeff) then + write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + "oz_coeff from read_o3data does not match value in GFS_typedefs.F90: ", & + oz_coeff, " /= ", size(Data(1)%Tbd%ozpl, dim=3) + errflg = 1 + end if + +!$OMP section + call read_h2odata (Model%h2o_phys, Model%me, Model%master) + + ! Consistency check that the hardcoded values for levh2o and + ! h2o_coeff in GFS_typedefs.F90 match what is set by read_o3data + ! in GFS_typedefs.F90: allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) + if (size(Data(1)%Tbd%h2opl, dim=2).ne.levh2o) then + write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + "levh2o from read_h2odata does not match value in GFS_typedefs.F90: ", & + levh2o, " /= ", size(Data(1)%Tbd%h2opl, dim=2) + errflg = 1 + end if + if (size(Data(1)%Tbd%h2opl, dim=3).ne.h2o_coeff) then + write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + "h2o_coeff from read_h2odata does not match value in GFS_typedefs.F90: ", & + h2o_coeff, " /= ", size(Data(1)%Tbd%h2opl, dim=3) + errflg = 1 + end if + +!$OMP section + if (Model%aero_in) then + ! Consistency check that the value for ntrcaerm set in GFS_typedefs.F90 + ! and used to allocate Tbd%aer_nm matches the value defined in aerclm_def + if (size(Data(1)%Tbd%aer_nm, dim=3).ne.ntrcaerm) then + write(errmsg,'(2a,i0,a,i0)') "Value error in GFS_phys_time_vary_init: ", & + "ntrcaerm from aerclm_def does not match value in GFS_typedefs.F90: ", & + ntrcaerm, " /= ", size(Data(1)%Tbd%aer_nm, dim=3) + errflg = 1 + else + ! Update the value of ntrcaer in aerclm_def with the value defined + ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. + ! If Model%aero_in is .true., then ntrcaer == ntrcaerm + ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) + ! Read aerosol climatology + call read_aerdata (Model%me,Model%master,Model%iflip,Model%idate) + endif + else + ! Update the value of ntrcaer in aerclm_def with the value defined + ! in GFS_typedefs.F90 that is used to allocate the Tbd DDT. + ! If Model%aero_in is .false., then ntrcaer == 1 + ntrcaer = size(Data(1)%Tbd%aer_nm, dim=3) + endif + +!$OMP section + if (Model%iccn) then + call read_cidata ( Model%me, Model%master) + ! No consistency check needed for in/ccn data, all values are + ! hardcoded in module iccn_def.F and GFS_typedefs.F90 + endif + +!$OMP end sections + + ! Update values of oz_pres in Interstitial data type for all threads + if (Model%ntoz > 0) then + Interstitial(nt)%oz_pres = oz_pres +!$OMP single + if (non_uniform_blocks) then + ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres + Interstitial(nthrds+1)%oz_pres = oz_pres + end if +!$OMP end single nowait + end if + + ! Update values of h2o_pres in Interstitial data type for all threads + if (Model%h2o_phys) then + Interstitial(nt)%h2o_pres = h2o_pres +!$OMP single + if (non_uniform_blocks) then + ! For non-uniform block sizes, set Interstitial(nthrds+1)%oz_pres + Interstitial(nthrds+1)%h2o_pres = h2o_pres + end if +!$OMP end single nowait + end if + + + !--- read in and initialize ozone + if (Model%ntoz > 0) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call setindxoz (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_o3, & + Data(nb)%Grid%jindx2_o3, Data(nb)%Grid%ddy_o3) + enddo +!$OMP end do + endif + + !--- read in and initialize stratospheric water + if (Model%h2o_phys) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call setindxh2o (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_h, & + Data(nb)%Grid%jindx2_h, Data(nb)%Grid%ddy_h) + enddo +!$OMP end do + endif + + !--- read in and initialize aerosols + if (Model%aero_in) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call setindxaer (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_aer, & + Data(nb)%Grid%jindx2_aer, Data(nb)%Grid%ddy_aer, Data(nb)%Grid%xlon_d, & + Data(nb)%Grid%iindx1_aer, Data(nb)%Grid%iindx2_aer, Data(nb)%Grid%ddx_aer, & + Model%me, Model%master) + enddo +!$OMP end do + endif + + !--- read in and initialize IN and CCN + if (Model%iccn) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call setindxci (Model%blksz(nb), Data(nb)%Grid%xlat_d, Data(nb)%Grid%jindx1_ci, & + Data(nb)%Grid%jindx2_ci, Data(nb)%Grid%ddy_ci, Data(nb)%Grid%xlon_d, & + Data(nb)%Grid%iindx1_ci, Data(nb)%Grid%iindx2_ci, Data(nb)%Grid%ddx_ci) + enddo +!$OMP end do + endif + +!$OMP end parallel + + !--- initial calculation of maps local ix -> global i and j, store in Tbd + ix = 0 + nb = 1 + do j = 1,Model%ny + do i = 1,Model%nx + ix = ix + 1 + if (ix .gt. Model%blksz(nb)) then + ix = 1 + nb = nb + 1 + endif + Data(nb)%Tbd%jmap(ix) = j + Data(nb)%Tbd%imap(ix) = i + enddo + enddo + + is_initialized = .true. + + end subroutine GFS_phys_time_vary_init + + +!> \section arg_table_GFS_phys_time_vary_finalize Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_phys_time_vary_finalize(errmsg, errflg) + + implicit none + + ! Interface variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + ! Deallocate ozone arrays + if (allocated(oz_lat) ) deallocate(oz_lat) + if (allocated(oz_pres) ) deallocate(oz_pres) + if (allocated(oz_time) ) deallocate(oz_time) + if (allocated(ozplin) ) deallocate(ozplin) + + ! Deallocate h2o arrays + if (allocated(h2o_lat) ) deallocate(h2o_lat) + if (allocated(h2o_pres)) deallocate(h2o_pres) + if (allocated(h2o_time)) deallocate(h2o_time) + if (allocated(h2oplin) ) deallocate(h2oplin) + + ! Deallocate aerosol arrays + if (allocated(aerin) ) deallocate(aerin) + if (allocated(aer_pres)) deallocate(aer_pres) + + ! Deallocate IN and CCN arrays + if (allocated(ciplin) ) deallocate(ciplin) + if (allocated(ccnin) ) deallocate(ccnin) + if (allocated(ci_pres) ) deallocate(ci_pres) + + is_initialized = .false. + + end subroutine GFS_phys_time_vary_finalize + + +!> \section arg_table_GFS_phys_time_vary_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | +!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) + + use mersenne_twister, only: random_setseed, random_number + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_data_type + + implicit none + + ! Interface variables + type(GFS_data_type), intent(in) :: Data(:) + type(GFS_control_type), intent(inout) :: Model + integer, intent(in) :: nthrds + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys + real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys + + integer :: i, j, k, iseed, iskip, ix, nb, nblks + real(kind=kind_phys) :: wrk(1) + real(kind=kind_phys) :: rannie(Model%cny) + real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization status + if (.not.is_initialized) then + write(errmsg,'(*(a))') "Logic error: GFS_phys_time_vary_run called before GFS_phys_time_vary_init" + errflg = 1 + return + end if + + nblks = size(Model%blksz) + + !--- switch for saving convective clouds - cnvc90.f + !--- aka Ken Campana/Yu-Tai Hou legacy + if ((mod(Model%kdt,Model%nsswr) == 0) .and. (Model%lsswr)) then + !--- initialize,accumulate,convert + Model%clstp = 1100 + min(Model%fhswr/con_hr,Model%fhour,con_99) + elseif (mod(Model%kdt,Model%nsswr) == 0) then + !--- accumulate,convert + Model%clstp = 0100 + min(Model%fhswr/con_hr,Model%fhour,con_99) + elseif (Model%lsswr) then + !--- initialize,accumulate + Model%clstp = 1100 + else + !--- accumulate + Model%clstp = 0100 + endif + +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP private (nb,iskip,ix,i,j,k) & +!$OMP shared (Model,Data,iseed,wrk,rannie,rndval) & +!$OMP shared (nblks) + + !--- random number needed for RAS and old SAS and when cal_pre=.true. + ! Model%imfdeepcnv < 0 when Model%ras = .true. + if ( (Model%imfdeepcnv <= 0 .or. Model%cal_pre) .and. Model%random_clds ) then +!$OMP single + iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0 + call random_setseed(iseed) + call random_number(wrk) + do i = 1,Model%cnx*Model%nrcm + iseed = iseed + nint(wrk(1)*1000.0) * i + call random_setseed(iseed) + call random_number(rannie) + rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny) + enddo +!$OMP end single + + do k = 1,Model%nrcm + iskip = (k-1)*Model%cnx*Model%cny +!$OMP do schedule (dynamic,1) + do nb=1,nblks + do ix=1,Model%blksz(nb) + j = Data(nb)%Tbd%jmap(ix) + i = Data(nb)%Tbd%imap(ix) + Data(nb)%Tbd%rann(ix,k) = rndval(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + iskip) + enddo + enddo +!$OMP end do + enddo + endif ! imfdeepcnv, cal_re, random_clds + + !--- o3 interpolation + if (Model%ntoz > 0) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call ozinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & + Data(nb)%Grid%jindx1_o3, Data(nb)%Grid%jindx2_o3, & + Data(nb)%Tbd%ozpl, Data(nb)%Grid%ddy_o3) + enddo +!$OMP end do + endif + + !--- h2o interpolation + if (Model%h2o_phys) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call h2ointerpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & + Data(nb)%Grid%jindx1_h, Data(nb)%Grid%jindx2_h, & + Data(nb)%Tbd%h2opl, Data(nb)%Grid%ddy_h) + enddo +!$OMP end do + endif + + !--- aerosol interpolation + if (Model%aero_in) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call aerinterpol (Model%me, Model%master, Model%blksz(nb), & + Model%idate, Model%fhour, & + Data(nb)%Grid%jindx1_aer, Data(nb)%Grid%jindx2_aer, & + Data(nb)%Grid%ddy_aer,Data(nb)%Grid%iindx1_aer, & + Data(nb)%Grid%iindx2_aer,Data(nb)%Grid%ddx_aer, & + Model%levs,Data(nb)%Statein%prsl, & + Data(nb)%Tbd%aer_nm) + enddo +!$OMP end do + endif + + !--- ICCN interpolation + if (Model%iccn) then +!$OMP do schedule (dynamic,1) + do nb = 1, nblks + call ciinterpol (Model%me, Model%blksz(nb), Model%idate, Model%fhour, & + Data(nb)%Grid%jindx1_ci, Data(nb)%Grid%jindx2_ci, & + Data(nb)%Grid%ddy_ci,Data(nb)%Grid%iindx1_ci, & + Data(nb)%Grid%iindx2_ci,Data(nb)%Grid%ddx_ci, & + Model%levs,Data(nb)%Statein%prsl, & + Data(nb)%Tbd%in_nm, Data(nb)%Tbd%ccn_nm) + enddo +!$OMP end do + endif + +!$OMP end parallel + + !--- repopulate specific time-varying sfc properties for AMIP/forecast runs + if (Model%nscyc > 0) then + if (mod(Model%kdt,Model%nscyc) == 1) THEN + call gcycle (nblks, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) + endif + endif + + !--- determine if diagnostics buckets need to be cleared + if (mod(Model%kdt,Model%nszero) == 1) then + do nb = 1,nblks + call Data(nb)%Intdiag%rad_zero (Model) + call Data(nb)%Intdiag%phys_zero (Model) + !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED + enddo + endif + + end subroutine GFS_phys_time_vary_run + + end module GFS_phys_time_vary diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 new file mode 100644 index 000000000..ac96e78d0 --- /dev/null +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -0,0 +1,114 @@ +!>\file GFS_rad_time_vary.F90 +!! Contains code related to GFS physics suite setup (radiation part of time_vary_step) + module GFS_rad_time_vary + + implicit none + + private + + public GFS_rad_time_vary_init, GFS_rad_time_vary_run, GFS_rad_time_vary_finalize + + contains + +!>\defgroup GFS_rad_time_vary GFS RRTMG Update +!!\ingroup RRTMG +!! @{ +!! \section arg_table_GFS_rad_time_vary_init Argument Table +!! + subroutine GFS_rad_time_vary_init + end subroutine GFS_rad_time_vary_init + +!> \section arg_table_GFS_rad_time_vary_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |-------------------|--------------------------------------------------------|-------------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | +!! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | +!! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_rad_time_vary_run (Model, Data, nthrds, errmsg, errflg) + + use physparam, only: ipsd0, ipsdlim, iaerflg + use mersenne_twister, only: random_setseed, random_index, random_stat + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, & + GFS_data_type + use radcons, only: qmin, con_100 + + implicit none + + type(GFS_control_type), intent(inout) :: Model + type(GFS_data_type), intent(inout) :: Data(:) + integer, intent(in) :: nthrds + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + type (random_stat) :: stat + integer :: ix, nb, j, i, nblks, ipseed + integer :: numrdm(Model%cnx*Model%cny*2) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (Model%lsswr .or. Model%lslwr) then + + nblks = size(Model%blksz) + + !--- call to GFS_radupdate_run is now in GFS_rrtmg_setup_run + +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP private (nb,ix,i,j) & +!$OMP shared (Model,Data,ipsdlim,ipsd0,ipseed) & +!$OMP shared (numrdm,stat,nblks) + + !--- set up random seed index in a reproducible way for entire cubed-sphere face (lat-lon grid) + if ((Model%isubc_lw==2) .or. (Model%isubc_sw==2)) then +!$OMP single + ipseed = mod(nint(con_100*sqrt(Model%sec)), ipsdlim) + 1 + ipsd0 + call random_setseed (ipseed, stat) + call random_index (ipsdlim, numrdm, stat) +!$OMP end single + +!$OMP do schedule (dynamic,1) + do nb=1,nblks + do ix=1,Model%blksz(nb) + j = Data(nb)%Tbd%jmap(ix) + i = Data(nb)%Tbd%imap(ix) + !--- for testing purposes, replace numrdm with '100' + Data(nb)%Tbd%icsdsw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx) + Data(nb)%Tbd%icsdlw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + Model%cnx*Model%cny) + enddo + enddo +!$OMP end do + endif ! isubc_lw and isubc_sw + + if (Model%imp_physics == 99) then + if (Model%kdt == 1) then +!$OMP do schedule (dynamic,1) + do nb = 1,nblks + Data(nb)%Tbd%phy_f3d(:,:,1) = Data(nb)%Statein%tgrs + Data(nb)%Tbd%phy_f3d(:,:,2) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) + Data(nb)%Tbd%phy_f3d(:,:,3) = Data(nb)%Statein%tgrs + Data(nb)%Tbd%phy_f3d(:,:,4) = max(qmin,Data(nb)%Statein%qgrs(:,:,1)) + Data(nb)%Tbd%phy_f2d(:,1) = Data(nb)%Statein%prsi(:,1) + Data(nb)%Tbd%phy_f2d(:,2) = Data(nb)%Statein%prsi(:,1) + enddo +!$OMP end do + endif + endif + +!$OMP end parallel + + endif + + end subroutine GFS_rad_time_vary_run + +!> \section arg_table_GFS_rad_time_vary_finalize Argument Table +!! + subroutine GFS_rad_time_vary_finalize() + end subroutine GFS_rad_time_vary_finalize +!! @} + end module GFS_rad_time_vary diff --git a/physics/GFS_stochastics.F90 b/physics/GFS_stochastics.F90 new file mode 100644 index 000000000..7fa2e256b --- /dev/null +++ b/physics/GFS_stochastics.F90 @@ -0,0 +1,249 @@ +!> \file GFS_stochastics.f90 +!! This file contains code previously in GFS_stochastics_driver. + + module GFS_stochastics + + contains + + subroutine GFS_stochastics_init () + end subroutine GFS_stochastics_init + + subroutine GFS_stochastics_finalize() + end subroutine GFS_stochastics_finalize + + +!>\defgroup gfs_stoch GFS Stochastics Physics Module +!! This module +!> @{ +!> \section arg_table_GFS_stochastics_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|---------------------------------------------------------------------------|--------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | do_sppt | flag_for_stochastic_surface_physics_perturbations | flag for stochastic surface physics perturbations | flag | 0 | logical | | in | F | +!! | use_zmtnblck | flag_for_mountain_blocking | flag for mountain blocking | flag | 0 | logical | | in | F | +!! | do_shum | flag_for_stochastic_shum_option | flag for stochastic shum option | flag | 0 | logical | | in | F | +!! | do_skeb | flag_for_stochastic_skeb_option | flag for stochastic skeb option | flag | 0 | logical | | in | F | +!! | zmtnblck | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | in | F | +!! | sppt_wts | weights_for_stochastic_sppt_perturbation | weights for stochastic sppt perturbation | none | 2 | real | kind_phys | inout | F | +!! | skebu_wts | weights_for_stochastic_skeb_perturbation_of_x_wind | weights for stochastic skeb perturbation of x wind | none | 2 | real | kind_phys | in | F | +!! | skebv_wts | weights_for_stochastic_skeb_perturbation_of_y_wind | weights for stochastic skeb perturbation of y wind | none | 2 | real | kind_phys | in | F | +!! | shum_wts | weights_for_stochastic_shum_perturbation | weights for stochastic shum perturbation | none | 2 | real | kind_phys | in | F | +!! | sppt_wts_inv | weights_for_stochastic_sppt_perturbation_flipped | weights for stochastic sppt perturbation, flipped | none | 2 | real | kind_phys | inout | F | +!! | skebu_wts_inv | weights_for_stochastic_skeb_perturbation_of_x_wind_flipped | weights for stochastic skeb perturbation of x wind, flipped | none | 2 | real | kind_phys | inout | F | +!! | skebv_wts_inv | weights_for_stochastic_skeb_perturbation_of_y_wind_flipped | weights for stochastic skeb perturbation of y wind, flipped | none | 2 | real | kind_phys | inout | F | +!! | shum_wts_inv | weights_for_stochastic_shum_perturbation_flipped | weights for stochastic shum perturbation, flipped | none | 2 | real | kind_phys | inout | F | +!! | diss_est | dissipation_estimate_of_air_temperature_at_model_layers | dissipation estimate model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | ugrs | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vgrs | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tgrs | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | qgrs | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gu0 | x_wind_updated_by_physics | zonal wind updated by physics | m s-1 | 2 | real | kind_phys | inout | F | +!! | gv0 | y_wind_updated_by_physics | meridional wind updated by physics | m s-1 | 2 | real | kind_phys | inout | F | +!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | +!! | gq0 | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | dtdtr | tendency_of_air_temperature_due_to_radiative_heating_on_physics_time_step | temp. change due to radiative heating per time step | K | 2 | real | kind_phys | in | F | +!! | rain | lwe_thickness_of_precipitation_amount_on_dynamics_timestep | total rain at this time step | m | 1 | real | kind_phys | in | F | +!! | rainc | lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep | convective rain at this time step | m | 1 | real | kind_phys | in | F | +!! | tprcp | nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep | total precipitation amount in each time step | m | 1 | real | kind_phys | inout | F | +!! | totprcp | accumulated_lwe_thickness_of_precipitation_amount | accumulated total precipitation | m | 1 | real | kind_phys | inout | F | +!! | cnvprcp | cumulative_lwe_thickness_of_convective_precipitation_amount | cumulative convective precipitation | m | 1 | real | kind_phys | inout | F | +!! | totprcpb | accumulated_lwe_thickness_of_precipitation_amount_in_bucket | accumulated total precipitation in bucket | m | 1 | real | kind_phys | inout | F | +!! | cnvprcpb | cumulative_lwe_thickness_of_convective_precipitation_amount_in_bucket | cumulative convective precipitation in bucket | m | 1 | real | kind_phys | inout | F | +!! | cplflx | flag_for_flux_coupling | flag controlling cplflx collection (default off) | flag | 0 | logical | | in | F | +!! | rain_cpl | lwe_thickness_of_precipitation_amount_for_coupling | total rain precipitation | m | 1 | real | kind_phys | inout | F | +!! | snow_cpl | lwe_thickness_of_snow_amount_for_coupling | total snow precipitation | m | 1 | real | kind_phys | inout | F | +!! | drain_cpl | tendency_of_lwe_thickness_of_precipitation_amount_for_coupling | change in rain_cpl (coupling_type) | m | 1 | real | kind_phys | in | F | +!! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!>\section gfs_stochy_general GFS_stochastics_run General Algorithm +!! This is the GFS stochastic physics driver. +!! Routines are called prior to radiation and physics steps to handle: +!! -# sets up various time/date variables +!! -# sets up various triggers +!! -# defines random seed indices for radiation (in a reproducible way) +!! -# interpolates coefficients for prognostic ozone calculation +!! -# performs surface data cycling via the GFS gcycle routine + subroutine GFS_stochastics_run (im, km, do_sppt, use_zmtnblck, do_shum, do_skeb, & + zmtnblck, sppt_wts, skebu_wts, skebv_wts, shum_wts,& + sppt_wts_inv, skebu_wts_inv, skebv_wts_inv, & + shum_wts_inv, diss_est, & + ugrs, vgrs, tgrs, qgrs, gu0, gv0, gt0, gq0, dtdtr, & + rain, rainc, tprcp, totprcp, cnvprcp, & + totprcpb, cnvprcpb, cplflx, & + rain_cpl, snow_cpl, drain_cpl, dsnow_cpl, & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im + integer, intent(in) :: km + logical, intent(in) :: do_sppt + logical, intent(in) :: use_zmtnblck + logical, intent(in) :: do_shum + logical, intent(in) :: do_skeb + !logical, intent(in) :: isppt_deep + real(kind_phys), dimension(1:im), intent(in) :: zmtnblck + ! sppt_wts only allocated if do_sppt == .true. + real(kind_phys), dimension(:,:), intent(inout) :: sppt_wts + ! skebu_wts, skebv_wts only allocated if do_skeb == .true. + real(kind_phys), dimension(:,:), intent(in) :: skebu_wts + real(kind_phys), dimension(:,:), intent(in) :: skebv_wts + ! shum_wts only allocated if do_shum == .true. + real(kind_phys), dimension(:,:), intent(in) :: shum_wts + ! inverse/flipped weights are always allocated + real(kind_phys), dimension(1:im,1:km), intent(inout) :: sppt_wts_inv + real(kind_phys), dimension(1:im,1:km), intent(inout) :: skebu_wts_inv + real(kind_phys), dimension(1:im,1:km), intent(inout) :: skebv_wts_inv + real(kind_phys), dimension(1:im,1:km), intent(inout) :: shum_wts_inv + real(kind_phys), dimension(1:im,1:km), intent(in) :: diss_est + real(kind_phys), dimension(1:im,1:km), intent(in) :: ugrs + real(kind_phys), dimension(1:im,1:km), intent(in) :: vgrs + real(kind_phys), dimension(1:im,1:km), intent(in) :: tgrs + real(kind_phys), dimension(1:im,1:km), intent(in) :: qgrs + real(kind_phys), dimension(1:im,1:km), intent(inout) :: gu0 + real(kind_phys), dimension(1:im,1:km), intent(inout) :: gv0 + real(kind_phys), dimension(1:im,1:km), intent(inout) :: gt0 + real(kind_phys), dimension(1:im,1:km), intent(inout) :: gq0 + ! dtdtr only allocated if do_sppt == .true. + real(kind_phys), dimension(:,:), intent(in) :: dtdtr + real(kind_phys), dimension(1:im), intent(in) :: rain + real(kind_phys), dimension(1:im), intent(in) :: rainc + real(kind_phys), dimension(1:im), intent(inout) :: tprcp + real(kind_phys), dimension(1:im), intent(inout) :: totprcp + real(kind_phys), dimension(1:im), intent(inout) :: cnvprcp + real(kind_phys), dimension(1:im), intent(inout) :: totprcpb + real(kind_phys), dimension(1:im), intent(inout) :: cnvprcpb + logical, intent(in) :: cplflx + ! rain_cpl, snow_cpl only allocated if cplflx == .true. or do_sppt == .true. + real(kind_phys), dimension(:), intent(inout) :: rain_cpl + real(kind_phys), dimension(:), intent(inout) :: snow_cpl + ! drain_cpl, dsnow_cpl only allocated if do_sppt == .true. + real(kind_phys), dimension(:), intent(in) :: drain_cpl + real(kind_phys), dimension(:), intent(in) :: dsnow_cpl + ! tconvtend ... vconvtend only allocated if isppt_deep == .true. + !real(kind_phys), dimension(:,:), intent(in) :: tconvtend + !real(kind_phys), dimension(:,:), intent(in) :: qconvtend + !real(kind_phys), dimension(:,:), intent(in) :: uconvtend + !real(kind_phys), dimension(:,:), intent(in) :: vconvtend + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + !--- local variables + integer :: k, i + real(kind=kind_phys) :: upert, vpert, tpert, qpert, qnew, sppt_vwt + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (do_sppt) then + do k=1,km + do i=1,im + sppt_vwt=1.0 + if (zmtnblck(i).EQ.0.0) then + sppt_vwt=1.0 + else + if (k.GT.zmtnblck(i)+2) then + sppt_vwt=1.0 + endif + if (k.LE.zmtnblck(i)) then + sppt_vwt=0.0 + endif + if (k.EQ.zmtnblck(i)+1) then + sppt_vwt=0.333333 + endif + if (k.EQ.zmtnblck(i)+2) then + sppt_vwt=0.666667 + endif + endif + if (use_zmtnblck)then + sppt_wts(i,k)=(sppt_wts(i,k)-1)*sppt_vwt+1.0 + endif + sppt_wts_inv(i,km-k+1)=sppt_wts(i,k) + + !if(isppt_deep)then + + ! upert = (gu0(i,k) - ugrs(i,k) - uconvtend(i,k)) + uconvtend(i,k) * sppt_wts(i,k) + ! vpert = (gv0(i,k) - vgrs(i,k) - vconvtend(i,k)) + vconvtend(i,k) * sppt_wts(i,k) + ! tpert = (gt0(i,k) - tgrs(i,k) - dtdtr(i,k) - tconvtend(i,k)) + tconvtend(i,k) * sppt_wts(i,k) + ! qpert = (gq0(i,k) - qgrs(i,k) - qconvtend(i,k)) + qconvtend(i,k) * sppt_wts(i,k) + + !else + + upert = (gu0(i,k) - ugrs(i,k)) * sppt_wts(i,k) + vpert = (gv0(i,k) - vgrs(i,k)) * sppt_wts(i,k) + tpert = (gt0(i,k) - tgrs(i,k) - dtdtr(i,k)) * sppt_wts(i,k) + qpert = (gq0(i,k) - qgrs(i,k)) * sppt_wts(i,k) + + !endif + + gu0(i,k) = ugrs(i,k)+upert + gv0(i,k) = vgrs(i,k)+vpert + + !negative humidity check + qnew = qgrs(i,k)+qpert + if (qnew >= 1.0e-10) then + gq0(i,k) = qnew + gt0(i,k) = tgrs(i,k) + tpert + dtdtr(i,k) + endif + enddo + enddo + + !if(isppt_deep)then + ! tprcp(:) = tprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) + ! totprcp(:) = totprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) + ! cnvprcp(:) = cnvprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) + !! ! bucket precipitation adjustment due to sppt + ! totprcpb(:) = totprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) + ! cnvprcpb(:) = cnvprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) + + ! if (cplflx) then !Need to make proper adjustments for deep convection only perturbations + ! rain_cpl(:) = rain_cpl(:) + (sppt_wts(:,15) - 1.0)*drain_cpl(:) + ! snow_cpl(:) = snow_cpl(:) + (sppt_wts(:,15) - 1.0)*dsnow_cpl(:) + ! endif + + !else + + ! instantaneous precip rate going into land model at the next time step + tprcp(:) = sppt_wts(:,15)*tprcp(:) + totprcp(:) = totprcp(:) + (sppt_wts(:,15) - 1 )*rain(:) + ! acccumulated total and convective preciptiation + cnvprcp(:) = cnvprcp(:) + (sppt_wts(:,15) - 1 )*rainc(:) + ! bucket precipitation adjustment due to sppt + totprcpb(:) = totprcpb(:) + (sppt_wts(:,15) - 1 )*rain(:) + cnvprcpb(:) = cnvprcpb(:) + (sppt_wts(:,15) - 1 )*rainc(:) + + if (cplflx) then + rain_cpl(:) = rain_cpl(:) + (sppt_wts(:,15) - 1.0)*drain_cpl(:) + snow_cpl(:) = snow_cpl(:) + (sppt_wts(:,15) - 1.0)*dsnow_cpl(:) + endif + + !endif + + endif + + if (do_shum) then + do k=1,km + gq0(:,k) = gq0(:,k)*(1.0 + shum_wts(:,k)) + shum_wts_inv(:,km-k+1) = shum_wts(:,k) + end do + endif + + if (do_skeb) then + do k=1,km + gu0(:,k) = gu0(:,k)+skebu_wts(:,k)*(diss_est(:,k)) + gv0(:,k) = gv0(:,k)+skebv_wts(:,k)*(diss_est(:,k)) + skebu_wts_inv(:,km-k+1) = skebu_wts(:,k) + skebv_wts_inv(:,km-k+1) = skebv_wts(:,k) + enddo + endif + + end subroutine GFS_stochastics_run + + end module GFS_stochastics +!> @} diff --git a/physics/GFS_suite_init_finalize_test.F90 b/physics/GFS_suite_init_finalize_test.F90 new file mode 100644 index 000000000..efd0530e2 --- /dev/null +++ b/physics/GFS_suite_init_finalize_test.F90 @@ -0,0 +1,68 @@ + module GFS_suite_ini_fini_test + + contains + +!> \section arg_table_GFS_suite_ini_fini_test_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_suite_ini_fini_test_init (errmsg, errflg) + + implicit none + + ! interface variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + write(0,*) "DH DEBUG: IN GFS_suite_ini_fini_test_init" + + end subroutine GFS_suite_ini_fini_test_init + +!> \section arg_table_GFS_suite_ini_fini_test_finalize Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_suite_ini_fini_test_finalize(errmsg, errflg) + + implicit none + + ! interface variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + write(0,*) "DH DEBUG: IN GFS_suite_ini_fini_test_finalize" + + end subroutine GFS_suite_ini_fini_test_finalize + +!> \section arg_table_GFS_suite_ini_fini_test_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|---------------------------------------------------------|---------------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_suite_ini_fini_test_run (errmsg, errflg) + + use GFS_typedefs, only: GFS_interstitial_type + + implicit none + + ! interface variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + write(errmsg,'(a)') "DH ERROR: GFS_suite_ini_fini_test_run should not be called" + errflg = 1 + + end subroutine GFS_suite_ini_fini_test_run + + end module GFS_suite_ini_fini_test diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 new file mode 100644 index 000000000..4fecabad5 --- /dev/null +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -0,0 +1,141 @@ +!> \file GFS_time_vary_pre.F90 +!! Contains code related to GFS physics suite setup (generic part of time_vary_step) + + module GFS_time_vary_pre + + use funcphys, only: gfuncphys + + implicit none + + private + + public GFS_time_vary_pre_init, GFS_time_vary_pre_run, GFS_time_vary_pre_finalize + + logical :: is_initialized = .false. + + contains + +!> \section arg_table_GFS_time_vary_pre_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_time_vary_pre_init (errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_initialized) return + + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. + call gfuncphys () + + is_initialized = .true. + + end subroutine GFS_time_vary_pre_init + + +!> \section arg_table_GFS_time_vary_pre_finalize Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_time_vary_pre_finalize(errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. is_initialized) return + + ! DH* this is the place to deallocate whatever is allocated by gfuncphys() in GFS_time_vary_pre_init + + is_initialized = .false. + + end subroutine GFS_time_vary_pre_finalize + + +!> \section arg_table_GFS_time_vary_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| +!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type + + implicit none + + type(GFS_control_type), intent(inout) :: Model + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys + real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind=kind_phys) :: rinc(5) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization status + if (.not.is_initialized) then + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" + errflg = 1 + return + end if + + !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- update calendars and triggers + rinc(1:5) = 0 + call w3difdat(Model%jdat,Model%idat,4,rinc) + Model%sec = rinc(4) + Model%phour = Model%sec/con_hr + !--- set current bucket hour + Model%zhour = Model%phour + Model%fhour = (Model%sec + Model%dtp)/con_hr + Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) + + Model%ipt = 1 + Model%lprnt = .false. + Model%lssav = .true. + + !--- radiation triggers + Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) + Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + + !--- set the solar hour based on a combination of phour and time initial hour + Model%solhr = mod(Model%phour+Model%idate(1),con_24) + + if ((Model%debug) .and. (Model%me == Model%master)) then + print *,' sec ', Model%sec + print *,' kdt ', Model%kdt + print *,' nsswr ', Model%nsswr + print *,' nslwr ', Model%nslwr + print *,' nscyc ', Model%nscyc + print *,' lsswr ', Model%lsswr + print *,' lslwr ', Model%lslwr + print *,' fhour ', Model%fhour + print *,' phour ', Model%phour + print *,' solhr ', Model%solhr + endif + + end subroutine GFS_time_vary_pre_run + + end module GFS_time_vary_pre diff --git a/physics/cu_ntiedtke.F90 b/physics/cu_ntiedtke.F90 new file mode 100644 index 000000000..954c4a65f --- /dev/null +++ b/physics/cu_ntiedtke.F90 @@ -0,0 +1,3840 @@ +!> \file cu_ntiedtke.F90 +!! This file contains the CCPP-compliant new Tiedtke scheme which parameterize +!! Shallow, deep, and mid-level convections in the model +!! Please refer to Tiedtke (1989), Bechtold et al. (2004,2008, 2014), +!! Zhang et al. (2011), Zhang and Wang (2017, 2018) +!! +!########################################################### + +module cu_ntiedtke + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use machine , only : kind_phys + ! DH* TODO - replace with arguments to subroutine calls, + ! this also requires redefining derived constants in the + ! parameter section below + use physcons, only:rd=>con_rd, rv=>con_rv, g=>con_g, & + & cpd=>con_cp, alv=>con_hvap, alf=>con_hfus + + implicit none + real(kind=kind_phys),private :: rcpd,vtmpc1,tmelt,als,t13, & + c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg + + real(kind=kind_phys),private :: rovcp,r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice + real(kind=kind_phys),private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon + integer,private :: momtrans,p650 + + parameter( & + t13 = 0.333333333,& + 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, & + als = alv+alf, & + 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, & + rovcp = rd*rcpd ) +! +! 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 ) +! ------- +! + logical :: isequil +! isequil: representing equilibrium and nonequilibrium convection +! ( .false. [default]; .true. [experimental]. Ref. Bechtold et al. 2014 JAS ) +! + parameter(isequil = .false. ) +! +!-------------------- +! switches for deep, mid, shallow convections, downdraft, and momemtum transport +! ------------------ + logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv + parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) +!-------------------- +!#################### end of variables definition########################## +!----------------------------------------------------------------------- +! +contains +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|--------------------|------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | mpirank | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | mpiroot | mpi_root | master MPI-rank | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_init(mpirank, mpiroot, errmsg, errflg) + + implicit none + + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + ! DH* temporary + if (mpirank==mpiroot) then + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + write(0,*) ' --- WARNING --- the CCPP New Tiedtke convection scheme is currently under development, use at your own risk --- WARNING ---' + write(0,*) ' -----------------------------------------------------------------------------------------------------------------------------' + end if + ! *DH temporary + + end subroutine cu_ntiedtke_init + + +!> \brief Brief description of the subroutine +!! +!! \section arg_table_cu_ntiedtke_finalize Argument Table +!! + subroutine cu_ntiedtke_finalize() + end subroutine cu_ntiedtke_finalize +! +! Tiedtke cumulus scheme from WRF with small modifications +! This scheme includes both deep and shallow convections +!=================== +! +!! +!! \section arg_table_cu_ntiedtke_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------|----------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | pu | x_wind_updated_by_physics | updated x-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pv | y_wind_updated_by_physics | updated y-direction wind | m s-1 | 2 | real | kind_phys | inout | F | +!! | pt | air_temperature_updated_by_physics | updated temperature | K | 2 | real | kind_phys | inout | F | +!! | pqv | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | pqvf | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | in | F | +!! | ptf | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | in | F | +!! | clw | convective_transportable_tracers | array to contain cloud water and other tracers | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | poz | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | pzz | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pomg | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | hfx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | zprecc | lwe_thickness_of_deep_convective_precipitation_amount | deep convective rainfall amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | lmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | lq | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | kbot | vertical_index_at_cloud_base | index for cloud base | index | 1 | integer | | out | F | +!! | ktop | vertical_index_at_cloud_top | index for cloud top | index | 1 | integer | | out | F | +!! | kcnv | flag_deep_convection | deep convection: 0=no, 1=yes | flag | 1 | integer | | out | F | +!! | ktrac | number_of_total_tracers | number of total tracers | count | 0 | integer | | in | F | +!! | ud_mf | instantaneous_atmosphere_updraft_convective_mass_flux | (updraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dd_mf | instantaneous_atmosphere_downdraft_convective_mass_flux | (downdraft mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | dt_mf | instantaneous_atmosphere_detrainment_convective_mass_flux | (detrainment mass flux) * delt | kg m-2 | 2 | real | kind_phys | out | F | +!! | cnvw | convective_cloud_water_mixing_ratio | convective cloud water | kg kg-1 | 2 | real | kind_phys | out | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!----------------------------------------------------------------------- +! level 1 subroutine 'tiecnvn' +!----------------------------------------------------------------- + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqvf,ptf,clw,poz,pzz,prsl,prsi,pomg, & + evap,hfx,zprecc,lmask,lq,ix,km,dt,dx,kbot,ktop,kcnv,& + ktrac,ud_mf,dd_mf,dt_mf,cnvw,cnvc,errmsg,errflg) +!----------------------------------------------------------------- +! this is the interface between the model and the mass +! flux convection module +!----------------------------------------------------------------- + implicit none +! in&out variables + integer, intent(in) :: lq, ix, km, ktrac + real(kind=kind_phys), intent(in ) :: dt + integer, dimension( lq ), intent(in) :: lmask + real(kind=kind_phys), dimension( lq ), intent(in ) :: evap, hfx, dx + real(kind=kind_phys), dimension( ix , km ), intent(inout) :: pu, pv, pt, pqv + real(kind=kind_phys), dimension( ix , km ), intent(in ) :: poz, prsl, pomg, pqvf, ptf + real(kind=kind_phys), dimension( ix , km+1 ), intent(in ) :: pzz, prsi + real(kind=kind_phys), dimension( ix , km, ktrac+2 ), intent(inout ) :: clw + + integer, dimension( lq ), intent(out) :: kbot, ktop, kcnv + real(kind=kind_phys), dimension( lq ), intent(out) :: zprecc + real(kind=kind_phys), dimension (lq,km), intent(out) :: ud_mf, dd_mf, dt_mf, cnvw, cnvc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! local variables + real(kind=kind_phys) 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,km+1) + real(kind=kind_phys) pqhfl(lq), zqq(lq,km), & + & prsfc(lq), pssfc(lq), pcte(lq,km), & + & phhfl(lq), pgeoh(lq,km+1) + real(kind=kind_phys) ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km),& + & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), zmfude_rate(lq,km),& + & zqsat(lq,km), zrain(lq) + real(kind=kind_phys) pcen(lq,km,ktrac),ptenc(lq,km,ktrac) + + integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) + logical locum(lq) +! + real(kind=kind_phys) ztmst,fliq,fice,ztc,zalf,tt + integer i,j,k,k1,n,km1 + real(kind=kind_phys) ztpp1 + real(kind=kind_phys) zew,zqs,zcor +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + km1 = km + 1 + 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)=pzz(j,1) + paph(j,km1)=prsi(j,1) + if(lmask(j).eq.1) then + lndj(j)=1 + else + lndj(j)=0 + end if + end do +! +! convert model variables for mflux scheme +! + do k=1,km + k1=km-k+1 + do j=1,lq + pcte(j,k1)=0.0 + pvom(j,k1)=0.0 + pvol(j,k1)=0.0 + ztp1(j,k1)=pt(j,k) + zqp1(j,k1)=pqv(j,k) + pum1(j,k1)=pu(j,k) + pvm1(j,k1)=pv(j,k) + pverv(j,k1)=pomg(j,k) + pgeo(j,k1)=poz(j,k) + pgeoh(j,k1)=pzz(j,k+1) + pap(j,k1)=prsl(j,k) + paph(j,k1)=prsi(j,k+1) + tt=ztp1(j,k1) + zew = foeewm(tt) + zqs = zew/pap(j,k1) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k1)=zqs*zcor + pqte(j,k1)=pqvf(j,k) + zqq(j,k1) =pqte(j,k1) + ptte(j,k1)=ptf(j,k) + ztt(j,k1) =ptte(j,k1) + ud_mf(j,k1)=0. + dd_mf(j,k1)=0. + dt_mf(j,k1)=0. + cnvw(j,k1)=0. + cnvc(j,k1)=0. + end do + end do + + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + pcen(j,k1,n) = clw(j,k,n+2) + ptenc(j,k1,n)= 0. + end do + end do + end do + +! print *, "pgeo=",pgeo(1,:) +! print *, "pgeoh=",pgeoh(1,:) +! print *, "pap=",pap(1,:) +! print *, "paph=",paph(1,:) +! print *, "ztp1=",ztp1(1,:) +! print *, "zqp1=",zqp1(1,:) +! print *, "pum1=",pum1(1,:) +! print *, "pvm1=",pvm1(1,:) +! print *, "pverv=",pverv(1,:) +! print *, "pqte=",pqte(1,:) +! print *, "ptte=",ptte(1,:) +! print *, "hfx=", pqhfl(1),phhfl(1),dx(1) +! +!----------------------------------------------------------------------- +!* 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, ktrac, pcen, ptenc,& + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain,& + & pcte, phhfl, lndj, pgeoh, zmfude_rate, dx) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + k1=km-k+1 + do j=1,lq + if(pcte(j,k1).gt.0.) then + fliq=foealfa(ztp1(j,k1)) + fice=1.0-fliq + clw(j,k,2)=clw(j,k,2)+fliq*pcte(j,k1)*ztmst + clw(j,k,1)=clw(j,k,1)+fice*pcte(j,k1)*ztmst + endif + end do + end do +! + do k=1,km + k1 = km-k+1 + do j=1,lq + pt(j,k) = ztp1(j,k1)+(ptte(j,k1)-ztt(j,k1))*ztmst + pqv(j,k)= zqp1(j,k1)+(pqte(j,k1)-zqq(j,k1))*ztmst + ud_mf(j,k)= zmfu(j,k1)*ztmst + dd_mf(j,k)= zmfd(j,k1)*ztmst + dt_mf(j,k)= zmfude_rate(j,k1)*ztmst + cnvw(j,k) = zlude(j,k1)*ztmst*g/(prsi(j,k)-prsi(j,k+1)) + cnvc(j,k) = 0.04 * log(1. + 675. * ud_mf(j,k)) + cnvc(j,k) = min(cnvc(j,k), 0.6) + cnvc(j,k) = max(cnvc(j,k), 0.0) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst*0.001) + kbot(j) = km-icbot(j)+1 + ktop(j) = km-ictop(j)+1 + if(ktype(j).eq.1 .or. ktype(j).eq.3) then + kcnv(j)=1 + else + kcnv(j)=0 + end if + end do + + if (lmfdudv) then + do k=1,km + k1=km-k+1 + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k1)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k1)*ztmst + end do + end do + endif +! + if (ktrac > 0) then + do n=1,ktrac + do k=1,km + k1=km-k+1 + do j=1,lq + clw(j,k,n+2)=pcen(j,k,n)+ptenc(j,k1,n)*ztmst + end do + end do + end do + end if +! + 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, ktrac, pcen, ptenc,& + & ktype, kcbot, kctop, ptu, pqu,& + & plu, plude, pmfu, pmfd, prain,& + & pcte, phhfl, lndj, zgeoh, pmfude_rate, dx) + 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,ktrac,klevp1,klevm1 + real(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pmflxr(klon,klevp1), pmflxs(klon,klevp1) + real(kind=kind_phys) zhcbase(klon),& + & zmfub(klon), zmfub1(klon),& + & zdhpbl(klon) + real(kind=kind_phys) zsfl(klon), zdpmel(klon,klev),& + & pcte(klon,klev), zcape(klon),& + & zcape1(klon), zcape2(klon),& + & ztauc(klon), ztaubl(klon),& + & zheat(klon) + real(kind=kind_phys) pcen(klon,klev,ktrac), ptenc(klon,klev,ktrac) + real(kind=kind_phys) wup(klon), zdqcv(klon) + real(kind=kind_phys) wbase(klon), zmfuub(klon) + real(kind=kind_phys) upbl(klon) + real(kind=kind_phys) dx(klon) + real(kind=kind_phys) pmfude_rate(klon,klev), pmfdde_rate(klon,klev) + real(kind=kind_phys) zmfuus(klon,klev), zmfdus(klon,klev) + real(kind=kind_phys) zmfudr(klon,klev), zmfddr(klon,klev) + real(kind=kind_phys) zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) + real(kind=kind_phys) 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), lldcum(klon) + logical loddraf(klon), llddraf3(klon), llo1, llo2(klon) + +! local varaiables + 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 + integer jl,jk,ik + integer ikb,ikt,icum,itopm2 + real(kind=kind_phys) ztmst,ztau,zerate,zderate,zmfa + real(kind=kind_phys) zmfs(klon),pmean(klev),zlon + real(kind=kind_phys) zduten,zdvten,ztdis,pgf_u,pgf_v +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + + zlon = real(klon) + do jk = klev , 1 , -1 + pmean(jk) = sum(pap(:,jk))/zlon + end do + p650 = klev-2 + do jk = klev , 3 , -1 + if ( pmean(jk)/pmean(klev)*1.013250e5 > 650.e2 ) p650 = jk + end do + +!-------------------------------------------------------------- +!* 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) + ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) + ztau = max(ztmst,ztau) + ztau = max(720.,ztau) + ztau = min(10800.,ztau) + if(isequil) 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) = 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 + + itopm2 = 2 +!---------------------------------------------------------- +!* 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 + if(ktype(jl) == 1 .or. ktype(jl) == 3) then + pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + else + pgf_u = 0. + pgf_v = 0. + end if + 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 + + !---------------------------------------------------------------------- + !* 11.0 CHEMICAL TRACER TRANSPORT + ! ------------------------- + + if ( ktrac > 0 ) then + ! transport switched off for mid-level convection + do jl = 1, klon + if ( ldcum(jl) .and. ktype(jl) /= 3 .and. & + kcbot(jl)-kctop(jl) >= 1 ) then + lldcum(jl) = .true. + llddraf3(jl) = loddraf(jl) + else + lldcum(jl) = .false. + llddraf3(jl) = .false. + end if + end do + ! check and correct mass fluxes for CFL criterium + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( lldcum(jl) .and. jk >= kctop(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*0.8*zcons + if ( pmfu(jl,jk) > zmfmax ) 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 + if ( lldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfudr(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + else + zmfuus(jl,jk) = 0. + zmfudr(jl,jk) = 0. + end if + if ( llddraf3(jl) .and. jk >= idtop(jl)-1 ) then + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfddr(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + else + zmfdus(jl,jk) = 0. + zmfddr(jl,jk) = 0. + end if + end do + end do + + call cuctracer(klon,klev,ktrac,kctop,idtop, & + lldcum,llddraf3,ztmst,paph,zmfuus,zmfdus, & + zmfudr,zmfddr,pcen,ptenc) + 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pten(klon,klev) + real(kind=kind_phys) ptu(klon,klev),pqu(klon,klev),plu(klon,klev) + real(kind=kind_phys) pgeo(klon,klev) + integer klab(klon,klev) + integer kctop(klon),kcbot(klon) + + real(kind=kind_phys) qfx(klon),hfx(klon) + real(kind=kind_phys) zph(klon) + integer lndj(klon) + logical loflag(klon), deepflag(klon), resetflag(klon) + +! output variables + real(kind=kind_phys) cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) + integer culab(klon,klev) + real(kind=kind_phys) wbase(klon) + integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) + logical ldcum(klon) + +! local variables + real(kind=kind_phys) zqold(klon) + real(kind=kind_phys) rho, part1, part2, root, conw, deltt, deltq + real(kind=kind_phys) eta(klon),dz(klon),coef(klon) + real(kind=kind_phys) dhen(klon,klev), dh(klon,klev) + real(kind=kind_phys) plude(klon,klev) + real(kind=kind_phys) kup(klon,klev) + real(kind=kind_phys) vptu(klon,klev),vten(klon,klev) + real(kind=kind_phys) zbuo(klon,klev),abuoy(klon,klev) + + 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 + integer nk,is,ikb,ikt + + real(kind=kind_phys) zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys) 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)))) + hfx(jl) = hfx(jl)*rho*cpd + qfx(jl) = qfx(jl)*rho + 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.55/(pgeo(jl,jk)*zrg)+1.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,klevm1-20,-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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) zdmfen(klon), zdmfde(klon),& + & zmfuu(klon), zmfuv(klon),& + & zpbase(klon), zqold(klon) + real(kind=kind_phys) phcbase(klon), zluold(klon) + real(kind=kind_phys) zprecip(klon), zlrain(klon,klev) + real(kind=kind_phys) zbuo(klon,klev), kup(klon,klev) + real(kind=kind_phys) wup(klon) + real(kind=kind_phys) wbase(klon), zodetr(klon,klev) + real(kind=kind_phys) plglac(klon,klev) + + real(kind=kind_phys) 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(kind=kind_phys) zoentr(klon), zdpmean(klon) + real(kind=kind_phys) 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(kind=kind_phys) ztmst,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 +!-------------------------------- +!* 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) !* (1.6-min(1.,pqen(jl,jk) / & + ! pqsen(jl,jk))) + 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 +! if ((paph(jl,ikb)-paph(jl,jk))>zdnoprc) 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(kind=kind_phys)): + +! *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(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys)): + +! *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(kind=kind_phys)): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real(kind=kind_phys)): + +! *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(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) pmfdde_rate(klon,klev) + logical lddraf(klon) + + real(kind=kind_phys) zdmfen(klon), zdmfde(klon), & + & zcond(klon), zoentr(klon), & + & zbuoy(klon) + real(kind=kind_phys) zph(klon) + logical llo2(klon) + logical llo1 +! local variables + integer jl,jk + integer is,ik,icall,ike, itopde(klon) + real(kind=kind_phys) zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys) 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(kind=kind_phys)): + +! *ztmst* 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(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1), pgeoh(klon,klev+1) + real(kind=kind_phys) 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(kind=kind_phys) 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(kind=kind_phys) ptent(klon,klev), ptenq(klon,klev) + real(kind=kind_phys) pcte(klon,klev) + +! local variables + integer jk , ik , jl + real(kind=kind_phys) zalv , zzp + real(kind=kind_phys) 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(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) 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(kind=kind_phys) ptenu(klon,klev), ptenv(klon,klev) + +!local variables + real(kind=kind_phys) zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & + zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) + + integer ik , ikb , jk , jl + real(kind=kind_phys) zzp, zdtdt + + real(kind=kind_phys) 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 cuctracer(klon,klev,ktrac,kctop,kdtop, & + ldcum,lddraf,ztmst,paph,pmfu,pmfd, & + pudrate,pddrate,pcen,ptenc) + implicit none + integer klon,klev,ktrac + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real(kind=kind_phys) ztmst + real(kind=kind_phys) paph(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pmfd(klon,klev) + real(kind=kind_phys) pudrate(klon,klev) + real(kind=kind_phys) pddrate(klon,klev) + real(kind=kind_phys) pcen(klon,klev,ktrac) + real(kind=kind_phys) ptenc(klon,klev,ktrac) + !---------------------------------------------------------------------- + integer ik , jk , jl , jn + real(kind=kind_phys) zzp , zmfa , zerate , zposi + ! ALLOCATABLE ARAYS + real(kind=kind_phys) , dimension(:,:,:) , allocatable :: zcen , zcu , zcd , & + ztenc , zmfc + real(kind=kind_phys) , dimension(:,:) , allocatable :: zdp + logical , dimension(:,:) , allocatable :: llcumask , llcumbas + !---------------------------------------------------------------------- + allocate (zcen(klon,klev,ktrac)) ! Half-level environmental values + allocate (zcu(klon,klev,ktrac)) ! Updraft values + allocate (zcd(klon,klev,ktrac)) ! Downdraft values + allocate (ztenc(klon,klev,ktrac)) ! Tendency + allocate (zmfc(klon,klev,ktrac)) ! Fluxes + allocate (zdp(klon,klev)) ! Pressure difference + allocate (llcumask(klon,klev)) ! Mask for convection + ! Initialize Cumulus mask + some setups + do jk = 2, klev + do jl = 1, klon + llcumask(jl,jk) = .false. + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + if ( jk >= kctop(jl)-1 ) llcumask(jl,jk) = .true. + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 1.0 DEFINE TRACERS AT HALF LEVELS + ! ----------------------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + zcen(jl,jk,jn) = pcen(jl,jk,jn) + zcd(jl,jk,jn) = pcen(jl,ik,jn) + zcu(jl,jk,jn) = pcen(jl,ik,jn) + zmfc(jl,jk,jn) = 0. + ztenc(jl,jk,jn)= 0. + end do + end do + + do jl = 1, klon + zcu(jl,klev,jn) = pcen(jl,klev,jn) + end do + !* 2.0 COMPUTE UPDRAFT VALUES + ! ---------------------- + do jk = klev - 1 , 3 , -1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pudrate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + if ( jk >= kctop(jl) ) then + zcu(jl,jk,jn) = (pmfu(jl,ik)*zcu(jl,ik,jn) + & + zerate*pcen(jl,jk,jn)-pudrate(jl,jk)*zcu(jl,ik,jn))*zmfa + end if + end if + end do + end do + !* 3.0 COMPUTE DOWNDRAFT VALUES + ! ------------------------ + do jk = 3 , klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) .and. jk == kdtop(jl) ) then + ! Nota: in order to avoid final negative Tracer values at LFS + ! the allowed value of ZCD depends on the jump in mass flux + ! at the LFS + zcd(jl,jk,jn) = 0.1*zcu(jl,jk,jn) + 0.9*pcen(jl,ik,jn) + else if ( lddraf(jl).and.jk>kdtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pddrate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = (pmfd(jl,ik)*zcd(jl,ik,jn) - & + zerate*pcen(jl,ik,jn)+pddrate(jl,jk)*zcd(jl,ik,jn))*zmfa + end if + end do + end do + ! In order to avoid negative Tracer at KLEV adjust ZCD + jk = klev + ik = jk - 1 + do jl = 1, klon + if ( lddraf(jl) ) then + zposi = -zdp(jl,jk) *(pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn)-(pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn)) + if ( pcen(jl,jk,jn)+zposi*ztmst < 0. ) then + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zcd(jl,jk,jn) = ((pmfu(jl,jk)+pmfd(jl,jk))*pcen(jl,ik,jn) - & + pmfu(jl,jk)*zcu(jl,jk,jn)+pcen(jl,jk,jn) / & + (ztmst*zdp(jl,jk)))*zmfa + end if + end if + end do + end do + !---------------------------------------------------------------------- + do jn = 1 , ktrac + !* 4.0 COMPUTE FLUXES + ! -------------- + do jk = 2 , klev + ik = jk - 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + zmfa = pmfu(jl,jk) + pmfd(jl,jk) + zmfc(jl,jk,jn) = pmfu(jl,jk)*zcu(jl,jk,jn) + & + pmfd(jl,jk)*zcd(jl,jk,jn) - zmfa*zcen(jl,ik,jn) + end if + end do + end do + !* 5.0 COMPUTE TENDENCIES = RHS + ! ------------------------ + do jk = 2 , klev - 1 + ik = jk + 1 + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ztenc(jl,jk,jn) = zdp(jl,jk)*(zmfc(jl,ik,jn)-zmfc(jl,jk,jn)) + end if + end do + end do + jk = klev + do jl = 1, klon + if ( ldcum(jl) ) ztenc(jl,jk,jn) = -zdp(jl,jk)*zmfc(jl,jk,jn) + end do + end do + !* 6.0 UPDATE TENDENCIES + ! ----------------- + do jn = 1, ktrac + do jk = 2, klev + do jl = 1, klon + if ( llcumask(jl,jk) ) then + ptenc(jl,jk,jn) = ptenc(jl,jk,jn)+ztenc(jl,jk,jn) + end if + end do + end do + end do + !--------------------------------------------------------------------------- + deallocate (llcumask) + deallocate (zdp) + deallocate (zmfc) + deallocate (ztenc) + deallocate (zcd) + deallocate (zcu) + deallocate (zcen) + end subroutine cuctracer + +!--------------------------------------------------------- +! level 4 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(kind=kind_phys)): + +! *psp* pressure pa + +! updated parameters (real(kind=kind_phys)): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + + integer klev,klon + real(kind=kind_phys) pt(klon,klev), pq(klon,klev), & + & psp(klon) + logical ldflag(klon) +! local variables + integer jl,jk + integer isum,kcall,kk + 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 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(kind=kind_phys) 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(kind=kind_phys) 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(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 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(kind=kind_phys) pgeoh(klon,klev+1) + real(kind=kind_phys) pmfu(klon,klev) + real(kind=kind_phys) pdmfen(klon) + real(kind=kind_phys) pdmfde(klon) + logical llo1 + integer jl + real(kind=kind_phys) zdz , zmf + real(kind=kind_phys) 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(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) 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) 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) 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) 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) tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + + real(kind=kind_phys) function foeldcp(tt) + implicit none + real(kind=kind_phys) tt + foeldcp = foedelta(tt)*ralvdcp + (1.-foedelta(tt))*ralsdcp + end function foeldcp + + real(kind=kind_phys) function foedelta(tt) + implicit none + real(kind=kind_phys) tt + foedelta = max(0.,sign(1.,tt-tmelt)) + end function foedelta + +end module cu_ntiedtke + diff --git a/physics/cu_ntiedtke_post.F90 b/physics/cu_ntiedtke_post.F90 new file mode 100644 index 000000000..fdc0b8b0f --- /dev/null +++ b/physics/cu_ntiedtke_post.F90 @@ -0,0 +1,53 @@ +!> \file cu_ntiedtke_post.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_post + + implicit none + + private + + public :: cu_ntiedtke_post_init, cu_ntiedtke_post_run, cu_ntiedtke_post_finalize + + contains + + subroutine cu_ntiedtke_post_init () + end subroutine cu_ntiedtke_post_init + + subroutine cu_ntiedtke_post_finalize() + end subroutine cu_ntiedtke_post_finalize + +!> \section arg_table_cu_ntiedtke_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | t | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | out | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_post_run (t, q, prevst, prevsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(out) :: prevst(:,:) + real(kind_phys), intent(out) :: prevsq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + prevst(:,:) = t(:,:) + prevsq(:,:) = q(:,:) + + end subroutine cu_ntiedtke_post_run + +end module cu_ntiedtke_post diff --git a/physics/cu_ntiedtke_pre.F90 b/physics/cu_ntiedtke_pre.F90 new file mode 100644 index 000000000..725b4a351 --- /dev/null +++ b/physics/cu_ntiedtke_pre.F90 @@ -0,0 +1,84 @@ +!> \file cu_ntiedtke_pre.F90 +!! Contains code related to New Tiedtke convective scheme + +module cu_ntiedtke_pre + + implicit none + + private + + public :: cu_ntiedtke_pre_init, cu_ntiedtke_pre_run, cu_ntiedtke_pre_finalize + + contains + + subroutine cu_ntiedtke_pre_init () + end subroutine cu_ntiedtke_pre_init + + subroutine cu_ntiedtke_pre_finalize() + end subroutine cu_ntiedtke_pre_finalize + +!> \section arg_table_cu_ntiedtke_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------|--------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | +!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | +!! | fhour | forecast_time | curent forecast time | h | 0 | real | kind_phys | in | F | +!! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | +!! | t | air_temperature | model layer mean temperature | K | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prevst | temperature_from_previous_timestep | temperature from previous time step | K | 2 | real | kind_phys | in | F | +!! | prevsq | moisture_from_previous_timestep | moisture from previous time step | kg kg-1 | 2 | real | kind_phys | in | F | +!! | forcet | temperature_tendency_due_to_dynamics | temperature tendency due to dynamics only | K s-1 | 2 | real | kind_phys | out | F | +!! | forceq | moisture_tendency_due_to_dynamics | moisture tendency due to dynamics only | kg kg-1 s-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cu_ntiedtke_pre_run (flag_init, flag_restart, kdt, fhour, dtp, t, q, prevst, prevsq, & + forcet, forceq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + logical, intent(in) :: flag_init + logical, intent(in) :: flag_restart + integer, intent(in) :: kdt + real(kind_phys), intent(in) :: fhour + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: t(:,:) + real(kind_phys), intent(in) :: q(:,:) + real(kind_phys), intent(in) :: prevst(:,:) + real(kind_phys), intent(in) :: prevsq(:,:) + real(kind_phys), intent(out) :: forcet(:,:) + real(kind_phys), intent(out) :: forceq(:,:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys) :: dtdyn + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! For restart runs, can assume that prevst and prevsq + ! are read from the restart files beforehand, same + ! for conv_act. + if(flag_init .and. .not.flag_restart) then + forcet(:,:)=0.0 + forceq(:,:)=0.0 + else + dtdyn=3600.0*(fhour)/kdt + if(dtp > dtdyn) then + forcet(:,:)=(t(:,:) - prevst(:,:))/dtp + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtp + else + forcet(:,:)=(t(:,:) - prevst(:,:))/dtdyn + forceq(:,:)=(q(:,:) - prevsq(:,:))/dtdyn + endif + endif + + end subroutine cu_ntiedtke_pre_run + +end module cu_ntiedtke_pre diff --git a/physics/gcm_shoc.F90 b/physics/gcm_shoc.F90 new file mode 100644 index 000000000..f2c9b7a7b --- /dev/null +++ b/physics/gcm_shoc.F90 @@ -0,0 +1,2040 @@ +!> \file gcm_shoc.F90 +!! Contains the Simplified Higher-Order Closure (SHOC) scheme. + +!> This module contains the CCPP-compliant SHOC scheme. +module shoc + use machine, only: kind_phys + + implicit none + + private + + public shoc_run, shoc_init, shoc_finalize + +contains + +subroutine shoc_init () +end subroutine shoc_init + +subroutine shoc_finalize () +end subroutine shoc_finalize + +#if 0 +!> \section arg_table_shoc_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------------|-----------------------------------------------------------------------------|---------------------------------------------------------------------------------------------|---------------|------|------------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | nx | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | nzm | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | +!! | shocaftcnv | flag_for_shoc_after_convection | flag to execute SHOC after convection | flag | 0 | logical | | in | F | +!! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | +!! | imp_physics | flag_for_microphysics_scheme | choice of microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_gfdl | flag_for_gfdl_microphysics_scheme | choice of GFDL microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_zhao_carr | flag_for_zhao_carr_microphysics_scheme | choice of Zhao-Carr microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_zhao_carr_pdf | flag_for_zhao_carr_pdf_microphysics_scheme | choice of Zhao-Carr microphysics scheme with PDF clouds | flag | 0 | integer | | in | F | +!! | imp_physics_mg | flag_for_morrison_gettelman_microphysics_scheme | choice of Morrison-Gettelman rmicrophysics scheme | flag | 0 | integer | | in | F | +!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | +!! | tcr | cloud_phase_transition_threshold_temperature | threshold temperature below which cloud starts to freeze | K | 0 | real | kind_phys | in | F | +!! | tcrf | cloud_phase_transition_denominator | denominator in cloud phase transition = 1/(tcr-tf) | K-1 | 0 | real | kind_phys | in | F | +!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | con_hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | con_hfus | latent_heat_of_fusion_of_water_at_0C | latent heat of fusion | J kg-1 | 0 | real | kind_phys | in | F | +!! | con_rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | +!! | con_fvirt | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | gq0_cloud_ice | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_snow | snow_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of snow water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_graupel | graupel_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of graupel updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | dtp | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | u | x_wind_updated_by_physics | zonal wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | +!! | v | y_wind_updated_by_physics | meridional wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | +!! | omega | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | rhc | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | +!! | supice | ice_supersaturation_threshold | ice supersaturation parameter for PDF clouds | none | 0 | real | kind_phys | in | F | +!! | pcrit | shoc_tke_dissipatation_pressure_threshold | pressure below which extra TKE diss. is applied in SHOC | Pa | 0 | real | kind_phys | in | F | +!! | cefac | shoc_tke_dissipation_tunable_parameter | mult. tuning parameter for TKE diss. in SHOC | none | 0 | real | kind_phys | in | F | +!! | cesfac | shoc_tke_dissipation_tunable_parameter_near_surface | mult. tuning parameter for TKE diss. at surface in SHOC | none | 0 | real | kind_phys | in | F | +!! | tkef1 | shoc_implicit_TKE_integration_uncentering_term | uncentering term for TKE integration in SHOC | none | 0 | real | kind_phys | in | F | +!! | dis_opt | shoc_flag_for_optional_surface_TKE_dissipation | flag for alt. TKE diss. near surface in SHOC (>0 = ON) | none | 0 | real | kind_phys | in | F | +!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | prnum | prandtl_number | turbulent Prandtl number | none | 2 | real | kind_phys | in | F | +!! | skip_macro | flag_skip_macro | flag to skip cloud macrophysics in Morrison scheme | flag | 0 | logical | | inout | F | +!! | clw_ice | ice_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of ice water in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | clw_liquid | cloud_condensed_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | gq0_cloud_liquid | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ncpl | cloud_droplet_number_concentration_updated_by_physics | number concentration of cloud droplets updated by physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncpi | ice_number_concentration_updated_by_physics | number concentration of ice updated by physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | +!! | gq0_water_vapor | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | cld_sgs | subgrid_scale_cloud_fraction_from_shoc | subgrid-scale cloud fraction from the SHOC scheme | frac | 2 | real | kind_phys | inout | F | +!! | tke | turbulent_kinetic_energy_convective_transport_tracer | turbulent kinetic energy in the convectively transported tracer array | m2 s-2 | 2 | real | kind_phys | inout | F | +!! | tkh | atmosphere_heat_diffusivity_from_shoc | diffusivity for heat from the SHOC scheme | m2 s-1 | 2 | real | kind_phys | inout | F | +!! | wthv_sec | kinematic_buoyancy_flux_from_shoc | upward kinematic buoyancy flux from the SHOC scheme | K m s-1 | 2 | real | kind_phys | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif +subroutine shoc_run (ix, nx, nzm, do_shoc, shocaftcnv, mg3_as_mg2, imp_physics, imp_physics_gfdl, imp_physics_zhao_carr, & + imp_physics_zhao_carr_pdf, imp_physics_mg, fprcp, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, & + con_fvirt, gq0_cloud_ice, gq0_rain, gq0_snow, gq0_graupel, dtp, me, prsl, phii, phil, u, v, omega, rhc, supice, pcrit, & + cefac, cesfac, tkef1, dis_opt, hflx, evap, prnum, & + skip_macro, clw_ice, clw_liquid, gq0_cloud_liquid, ncpl, ncpi, gt0, gq0_water_vapor, cld_sgs, tke, tkh, wthv_sec, & + errmsg, errflg) + + implicit none + + integer, intent(in) :: ix, nx, nzm, imp_physics, imp_physics_gfdl, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_mg, fprcp, me + logical, intent(in) :: do_shoc, shocaftcnv, mg3_as_mg2 + real(kind=kind_phys), intent(in) :: tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, con_fvirt, & + dtp, supice, pcrit, cefac, cesfac, tkef1, dis_opt + ! + real(kind=kind_phys), intent(in), dimension(nx) :: hflx, evap + real(kind=kind_phys), intent(in), dimension(nx,nzm) :: gq0_cloud_ice, gq0_rain, gq0_snow, gq0_graupel, prsl, phil, & + u, v, omega, rhc, prnum + real(kind=kind_phys), intent(in), dimension(nx,nzm+1) :: phii + ! + logical, intent(inout) :: skip_macro + real(kind=kind_phys), intent(inout), dimension(nx,nzm) :: clw_ice, clw_liquid, gq0_cloud_liquid, ncpl, ncpi, gt0, & + gq0_water_vapor, cld_sgs, tke, tkh, wthv_sec + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + real(kind=kind_phys), parameter :: epsq = 1.e-20 + + integer :: i, k + + real(kind=kind_phys) :: tem + real(kind=kind_phys), dimension(nx,nzm) :: qsnw ! qsnw can be local to this routine + real(kind=kind_phys), dimension(nx,nzm) :: qgl ! qgl can be local to this routine + +! Initialize CCPP error handling variables + + errmsg = '' + errflg = 0 + + if (shocaftcnv) then + if (imp_physics == imp_physics_mg) then + skip_macro = do_shoc + if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,nzm + do i=1,nx + !GF - gq0(ntrw) is passed in directly, no need to copy + !qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = 0.0 + enddo + enddo + elseif (fprcp > 1) then + do k=1,nzm + do i=1,nx + !qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k) + qgl(i,k) = 0.0 + enddo + enddo + endif + endif + else + if (imp_physics == imp_physics_mg) then + skip_macro = do_shoc + do k=1,nzm + do i=1,nx + ! DH* THESE ARE NOT IN THE ORIGINAL CODE (AND THEY WERE NEVER) ::: clw_ice(i,k) = gq0_cloud_ice(i,k) ! ice + ! DH* THESE ARE NOT IN THE ORIGINAL CODE (AND THEY WERE NEVER) ::: clw_liquid(i,k) = gq0_cloud_liquid(i,k) ! water + !GF - since gq0(ntlnc/ntinc) are passed in directly, no need to copy + !ncpl(i,k) = Stateout%gq0(i,k,ntlnc) + !ncpi(i,k) = Stateout%gq0(i,k,ntinc) + enddo + enddo + if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,nzm + do i=1,nx + !GF - gq0(ntrw) is passed in directly, no need to copy + !qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = 0.0 + enddo + enddo + elseif (fprcp > 1) then + do k=1,nzm + do i=1,nx + !qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k) + qgl(i,k) = 0.0 + clw_ice(i,k) = clw_ice(i,k) + gq0_graupel(i,k) + enddo + enddo + endif + elseif (imp_physics == imp_physics_gfdl) then ! GFDL MP - needs modify for condensation + do k=1,nzm + do i=1,nx + clw_ice(i,k) = gq0_cloud_ice(i,k) ! ice + clw_liquid(i,k) = gq0_cloud_liquid(i,k) ! water + !qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = 0.0 + enddo + enddo + elseif (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then + do k=1,nzm + do i=1,nx + if (abs(gq0_cloud_liquid(i,k)) < epsq) then + gq0_cloud_liquid(i,k) = 0.0 + endif + tem = gq0_cloud_liquid(i,k) * max(0.0, MIN(1.0, (tcr-gt0(i,k))*tcrf)) + clw_ice(i,k) = tem ! ice + clw_liquid(i,k) = gq0_cloud_liquid(i,k) - tem ! water + qsnw(i,k) = 0.0 + qgl(i,k) = 0.0 + enddo + enddo + endif + endif !shocaftcnv + + ! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds + ! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients + ! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' + + !GFDL lat has no meaning inside of shoc - changed to "1" + + + ! DH* can we pass in gq0_graupel? is that zero? the original code + ! passes in qgl which is zero (always? sometimes?), in shoc_work + ! this qgl gets added to qpi, qpi = qpi_i + qgl with qpi_i = qsnw; + ! - with the above qsnw(i,k) = gq0_snow(i,k) + gq0_graupel(i,k), + ! would that be double counting? *DH + call shoc_work (ix, nx, 1, nzm, nzm+1, dtp, me, 1, prsl, & + phii, phil, u, v, omega, gt0, & + gq0_water_vapor, clw_ice, clw_liquid, qsnw, gq0_rain, & + qgl, rhc, supice, pcrit, cefac, cesfac, tkef1, dis_opt, & + cld_sgs, tke, hflx, evap, prnum, tkh, wthv_sec, .false., 1, ncpl, ncpi, & + con_cp, con_g, con_hvap, con_hfus, con_rv, con_rd, con_pi, con_fvirt) + + if (.not.shocaftcnv) then + if (imp_physics == imp_physics_mg .and. fprcp > 1) then + do k=1,nzm + do i=1,nx + clw_ice(i,k) = clw_ice(i,k) - gq0_graupel(i,k) + enddo + enddo + endif + endif ! .not. shocaftcnv + + !GF since gq0(ntlnc/ntinc) are passed in directly, no need to copy back + ! if (ntlnc > 0 .and. ntinc > 0 .and. ncld >= 2) then + ! do k=1,nzm + ! do i=1,nx + ! Stateout%gq0(i,k,ntlnc) = ncpl(i,k) + ! Stateout%gq0(i,k,ntinc) = ncpi(i,k) + ! enddo + ! enddo + ! endif + +end subroutine shoc_run + + ! Implementation of the Simplified High Order Closure (SHOC) scheme + ! of Bogenschutz and Krueger (2013), J. Adv. Model. Earth Syst, 5, 195-211, + ! doi: 10.1002/jame.200118. (further referred to as BK13) + ! in a single column form suitable for use in a GCM physics package. + ! Alex Belochitski, heavily based on the code of Peter Bogenschutz. + ! S Moorthi - optimization, cleanup, improve and customize for gsm + ! - improved solution for sgs-tke equation + ! S Moorthi - 05-11-17 - modified shear production term to eliminate + ! spurious tke ove Antarctica. + ! S Moorthi - 01-12-17 - added extra pressure dependent tke dissipation at + ! pressures below a critical value pcrit + ! S Moorthi - 04-12-17 - fixed a bug in the definition of hl on input + ! replacing fac_fus by fac_sub + ! S.Moorthi - 00-00-17 - added an alternate option for near boundary cek following + ! Scipion et. al., from U. Oklahoma. + subroutine shoc_work (ix, nx, ny, nzm, nz, dtn, me, lat, & + prsl, phii, phil, u, v, omega, tabs, & + qwv, qi, qc, qpi_i, qpl, qgl, rhc, supice, & + pcrit, cefac, cesfac, tkef1, dis_opt, & + cld_sgs, tke, hflx, evap, prnum, tkh, & + wthv_sec, lprnt, ipr, ncpl, ncpi, & + cp, ggr, lcond, lfus, rv, rgas, pi, epsv) + + use funcphys , only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice + + implicit none + + real, intent(in) :: cp, ggr, lcond, lfus, rv, rgas, pi, epsv + integer, intent(in) :: ix ! max number of points in the physics window in the x + integer, intent(in) :: nx ! Number of points in the physics window in the x + integer, intent(in) :: ny ! and y directions + integer, intent(in) :: me ! MPI rank + integer, intent(in) :: lat ! latitude + + integer, intent(in) :: nzm ! Number of vertical layers + integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) + real, intent(in) :: dtn ! Physics time step, s + + real, intent(in) :: pcrit ! pressure in Pa below which additional tke dissipation is applied + real, intent(in) :: cefac ! tunable multiplier to dissipation term + real, intent(in) :: cesfac ! tunable multiplier to dissipation term for bottom level + real, intent(in) :: tkef1 ! uncentering terms in implicit tke integration + real, intent(in) :: dis_opt ! when > 0 use different formula for near surface dissipation + + real, intent(in) :: hflx(nx) + real, intent(in) :: evap(nx) + +! The interface is talored to GFS in a sense that input variables are 2D + + real, intent(in) :: prsl (ix,ny,nzm) ! mean layer presure + real, intent(in) :: phii (ix,ny,nz ) ! interface geopotential height + real, intent(in) :: phil (ix,ny,nzm) ! layer geopotential height + real, intent(in) :: u (ix,ny,nzm) ! u-wind, m/s + real, intent(in) :: v (ix,ny,nzm) ! v-wind, m/s + real, intent(in) :: omega (ix,ny,nzm) ! omega, Pa/s + real, intent(inout) :: tabs (ix,ny,nzm) ! temperature, K + real, intent(inout) :: qwv (ix,ny,nzm) ! water vapor mixing ratio, kg/kg + real, intent(inout) :: qc (ix,ny,nzm) ! cloud water mixing ratio, kg/kg + real, intent(inout) :: qi (ix,ny,nzm) ! cloud ice mixing ratio, kg/kg +! Anning Cheng 03/11/2016 SHOC feedback to number concentration + real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 + real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 + real, intent(in) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - not used at this time + real, intent(in) :: qpi_i (nx,ny,nzm) ! snow mixing ratio, kg/kg - not used at this time + real, intent(in) :: qgl (nx,ny,nzm) ! graupel mixing ratio, kg/kg - not used at this time + real, intent(in) :: rhc (nx,ny,nzm) ! critical relative humidity + real, intent(in) :: supice ! ice supersaturation parameter + real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction +! real, intent(inout) :: cld_sgs(nx,ny,nzm) ! sgs cloud fraction + real, intent(inout) :: tke (ix,ny,nzm) ! turbulent kinetic energy. m**2/s**2 +! real, intent(inout) :: tk (nx,ny,nzm) ! eddy viscosity + real, intent(inout) :: tkh (ix,ny,nzm) ! eddy diffusivity + real, intent(in) :: prnum (nx,ny,nzm) ! turbulent Prandtl number + real, intent(inout) :: wthv_sec (ix,ny,nzm) ! Buoyancy flux, K*m/s + + real, parameter :: zero=0.0, one=1.0, half=0.5, two=2.0, eps=0.622, & + three=3.0, oneb3=one/three, twoby3=two/three + real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.0, & + skew_facw=1.2, skew_fact=0.0, & + tkhmax=300.0 + real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, rog, sqrtpii, & + epsterm, onebeps, onebrvcp + +! SHOC tunable parameters + + real, parameter :: lambda = 0.04 +! real, parameter :: min_tke = 1e-6 ! Minumum TKE value, m**2/s**2 + real, parameter :: min_tke = 1e-4 ! Minumum TKE value, m**2/s**2 +! real, parameter :: max_tke = 100.0 ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 40.0 ! Maximum TKE value, m**2/s**2 +! Maximum turbulent eddy length scale, m +! real, parameter :: max_eddy_length_scale = 2000. + real, parameter :: max_eddy_length_scale = 1000. +! Maximum "return-to-isotropy" time scale, s + real, parameter :: max_eddy_dissipation_time_scale = 2000. + real, parameter :: Pr = 1.0 ! Prandtl number + +! Constants for the TKE dissipation term based on Deardorff (1980) + real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01, atmin=0.01, atmax=one-atmin + real, parameter :: Cs = 0.15, epsln=1.0e-6 + real, parameter :: Ck = 0.1 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 + +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 3.0 , Ces = Ce +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.5 , Ces = Ce * 3.0 / 2.5 +! real, parameter :: Ces = Ce/0.7*3.0 + +! real, parameter :: Ce = Ck**3/(0.7*Cs**4), Ces = Ce*3.0/0.7 ! Commented Moor + + real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce +! real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce*3.0/0.7 + +! real, parameter :: vonk=0.35 ! Von Karman constant + real, parameter :: vonk=0.4 ! Von Karman constant Moorthi - as in GFS + real, parameter :: tscale=400.! time scale set based off of similarity results of BK13, s + real, parameter :: w_tol_sqd = 4.0e-04 ! Min vlaue of second moment of w +! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w + real, parameter :: w_thresh = 0.0, thresh = 0.0 + real, parameter :: w3_tol = 1.0e-20 ! Min vlaue of third moment of w + + +! These parameters are a tie-in with a microphysical scheme +! Double check their values for the Zhao-Carr scheme. + real, parameter :: tbgmin = 233.16 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 258.16 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 253.16 ! Minimum temperature for cloud water., K + real, parameter :: tbgmax = 273.16 ! Maximum temperature for cloud ice, K + real, parameter :: a_bg = one/(tbgmax-tbgmin) +! +! Parameters to tune the second order moments- No tuning is performed currently + + real, parameter :: thl2tune = 1.0, qw2tune = 1.0, qwthl2tune = 1.0, & +! thl_tol = 1.e-4, rt_tol = 1.e-8, basetemp = 300.0 + thl_tol = 1.e-2, rt_tol = 1.e-4, basetemp = 300.0 + + integer, parameter :: nitr=6 + +! Local variables. Note that pressure is in millibars in the SHOC code. + + logical lprnt + integer ipr + + real zl (nx,ny,nzm) ! height of the pressure levels above surface, m + real zi (nx,ny,nz) ! height of the interface levels, m + real adzl (nx,ny,nzm) ! layer thickness i.e. zi(k+1)-zi(k) - defined at levels + real adzi (nx,ny,nz) ! level thickness i.e. zl(k)-zl(k-1) - defined at interface + + real hl (nx,ny,nzm) ! liquid/ice water static energy , K + real qv (nx,ny,nzm) ! water vapor, kg/kg + real qcl (nx,ny,nzm) ! liquid water (condensate), kg/kg + real qci (nx,ny,nzm) ! ice water (condensate), kg/kg + real w (nx,ny,nzm) ! z-wind, m/s + real bet (nx,ny,nzm) ! ggr/tv0 + real gamaz (nx,ny,nzm) ! ggr/cp*z + real qpi (nx,ny,nzm) ! snow + graupel mixing ratio, kg/kg +! real qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg + +! Moments of the trivariate double Gaussian PDF for the SGS total water mixing ratio +! SGS liquid/ice static energy, and vertical velocity + + real qw_sec (nx,ny,nzm) ! Second moment total water mixing ratio, kg^2/kg^2 + real thl_sec (nx,ny,nzm) ! Second moment liquid/ice static energy, K^2 + real qwthl_sec(nx,ny,nzm) ! Covariance tot. wat. mix. ratio and static energy, K*kg/kg + real wqw_sec (nx,ny,nzm) ! Turbulent flux of tot. wat. mix., kg/kg*m/s + real wthl_sec (nx,ny,nzm) ! Turbulent flux of liquid/ice static energy, K*m/s + real w_sec (nx,ny,nzm) ! Second moment of vertical velocity, m**2/s**2 + real w3 (nx,ny,nzm) ! Third moment of vertical velocity, m**3/s**3 + real wqp_sec (nx,ny,nzm) ! Turbulent flux of precipitation, kg/kg*m/s + +! Eddy length formulation + real smixt (nx,ny,nzm) ! Turbulent length scale, m + real isotropy (nx,ny,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s +! real isotropy_debug (nx,ny,nzm) ! Return to isotropy scale, s without artificial limits + real brunt (nx,ny,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 + real conv_vel2(nx,ny,nzm) ! Convective velocity scale cubed, m^3/s^3 + + real cek(nx,ny) + +! Output of SHOC + real diag_frac, diag_qn, diag_qi, diag_ql + +! real diag_frac(nx,ny,nzm) ! SGS cloud fraction +! real diag_qn (nx,ny,nzm) ! SGS cloud+ice condensate, kg/kg +! real diag_qi (nx,ny,nzm) ! SGS ice condensate, kg/kg +! real diag_ql (nx,ny,nzm) ! SGS liquid condensate, kg/kg + + +! Horizontally averaged variables +! real conv_vel(nzm) ! Convective velocity scale cubed, m^3/s^3 + real wqlsb (nzm) ! liquid water flux, kg/kg/ m/s + real wqisb (nzm) ! ice flux, kg/kg m/s +! real thlv (nzm) ! Grid-scale level-average virtual potential temperature +! (not used) + + +! Local variables + +! real, dimension(nx,ny,nzm) :: tkesbbuoy, tkesbshear, tkesbdiss, tkesbbuoy_debug & +! tkebuoy_sgs, total_water, tscale1_debug, brunt2 + + real, dimension(nx,ny,nzm) :: total_water, brunt2, thv, tkesbdiss + real, dimension(nx,ny,nzm) :: def2 + real, dimension(nx,ny) :: denom, numer, l_inf, cldarr, thedz, thedz2 + + real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & + conv_var, tkes, skew_w, skew_qw, aterm, w1_1, w1_2, w2_1, & + w2_2, w3var, thl1_1, thl1_2, thl2_1, thl2_2, qw1_1, qw1_2, qw2_1, & + qw2_2, ql1, ql2, w_ql1, w_ql2, & + r_qwthl_1, r_wqw_1, r_wthl_1, testvar, s1, s2, std_s1, std_s2, C1, C2, & + thl_first, qw_first, w_first, Tl1_1, Tl1_2, betatest, pval, pkap, & + w2thl, w2qw,w2ql, w2ql_1, w2ql_2, & + thec, thlsec, qwsec, qwthlsec, wqwsec, wthlsec, thestd,dum, & + cqt1, cthl1, cqt2, cthl2, qn1, qn2, qi1, qi2, omn1, omn2, & + basetemp2, beta1, beta2, qs1, qs2, & + esval1_1, esval2_1, esval1_2, esval2_2, om1, om2, & + lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & + sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & + sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & + corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac + + + integer i,j,k,km1,ku,kd,ka,kb + +!calculate derived constants + lsub = lcond+lfus + fac_cond = lcond/cp + fac_fus = lfus/cp + cpolv = cp/lcond + fac_sub = lsub/cp + ggri = 1.0/ggr + kapa = rgas/cp + gocp = ggr/cp + rog = rgas*ggri + sqrtpii = one/sqrt(pi+pi) + epsterm = rgas/rv + onebeps = one/epsterm + onebrvcp= one/(rv*cp) + +! Map GFS variables to those of SHOC - SHOC operates on 3D fields +! Here a Y-dimension is added to the input variables, along with some unit conversions + + do k=1,nz + do j=1,ny + do i=1,nx + zi(i,j,k) = phii(i,j,k) * ggri + enddo + enddo + enddo + +! if (lprnt) write(0,*)' tabsin=',tabs(ipr,1,1:40) +! if (lprnt) write(0,*)' qcin=',qc(ipr,1,1:40) +! if (lprnt) write(0,*)' qwvin=',qwv(ipr,1,1:40) +! if (lprnt) write(0,*)' qiin=',qi(ipr,1,1:40) +! if (lprnt) write(0,*)' qplin=',qpl(ipr,1,1:40) +! if (lprnt) write(0,*)' qpiin=',qpi(ipr,1,1:40) +! +! move water from vapor to condensate if the condensate is negative +! + do k=1,nzm + do j=1,ny + do i=1,nx + if (qc(i,j,k) < zero) then + wrk = qwv(i,j,k) + qc(i,j,k) + if (wrk >= zero) then + qwv(i,j,k) = wrk + tabs(i,j,k) = tabs(i,j,k) - fac_cond * qc(i,j,k) + qc(i,j,k) = zero + else + qc(i,j,k) = zero + tabs(i,j,k) = tabs(i,j,k) + fac_cond * qwv(i,j,k) + qwv(i,j,k) = zero + endif + endif + if (qi(i,j,k) < zero) then + wrk = qwv(i,j,k) + qi(i,j,k) + if (wrk >= zero) then + qwv(i,j,k) = wrk + tabs(i,j,k) = tabs(i,j,k) - fac_sub * qi(i,j,k) + qi(i,j,k) = zero + else + qi(i,j,k) = zero + tabs(i,j,k) = tabs(i,j,k) + fac_sub * qwv(i,j,k) + qwv(i,j,k) = zero + endif + endif + enddo + enddo + enddo + +! if (lprnt) write(0,*)' tabsin2=',tabs(ipr,1,1:40) + + do k=1,nzm + do j=1,ny + do i=1,nx + zl(i,j,k) = phil(i,j,k) * ggri + wrk = one / prsl(i,j,k) + qv(i,j,k) = max(qwv(i,j,k), zero) + thv(i,j,k) = tabs(i,j,k) * (one+epsv*qv(i,j,k)) + w(i,j,k) = - rog * omega(i,j,k) * thv(i,j,k) * wrk + qcl(i,j,k) = max(qc(i,j,k), zero) + qci(i,j,k) = max(qi(i,j,k), zero) + qpi(i,j,k) = qpi_i(i,j,k) + qgl(i,j,k) ! add snow and graupel together +! +! qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow +! qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow + + wqp_sec(i,j,k) = zero ! Turbulent flux of precipiation +! + total_water(i,j,k) = qcl(i,j,k) + qci(i,j,k) + qv(i,j,k) + + prespot = (100000.0*wrk) ** kapa ! Exner function + bet(i,j,k) = ggr/(tabs(i,j,k)*prespot) ! Moorthi + thv(i,j,k) = thv(i,j,k)*prespot ! Moorthi +! +! Lapse rate * height = reference temperature + gamaz(i,j,k) = gocp * zl(i,j,k) + +! Liquid/ice water static energy - ! Note the the units are degrees K + hl(i,j,k) = tabs(i,j,k) + gamaz(i,j,k) - fac_cond*(qcl(i,j,k)+qpl(i,j,k)) & + - fac_sub *(qci(i,j,k)+qpi(i,j,k)) + w3(i,j,k) = zero + enddo + enddo + enddo + +! if (lprnt) write(0,*)' hlin=',hl(ipr,1,1:40) + +! Define vertical grid increments for later use in the vertical differentiation + + do k=2,nzm + km1 = k - 1 + do j=1,ny + do i=1,nx + adzi(i,j,k) = zl(i,j,k) - zl(i,j,km1) + adzl(i,j,km1) = zi(i,j,k) - zi(i,j,km1) + enddo + enddo + enddo + do j=1,ny + do i=1,nx + adzi(i,j,1) = (zl(i,j,1)-zi(i,j,1)) ! unused in the code + adzi(i,j,nz) = adzi(i,j,nzm) ! at the top - probably unused + adzl(i,j,nzm) = zi(i,j,nz) - zi(i,j,nzm) +! + wthl_sec(i,j,1) = hflx(i) + wqw_sec(i,j,1) = evap(i) + enddo + enddo + + + call tke_shoc() ! Integrate prognostic TKE equation forward in time + + +! diagnose second order moments of the subgrid PDF following +! Redelsperger J.L., and G. Sommeria, 1986, JAS, 43, 2619-2635 sans the use of stabilty +! weighting functions - Result is in global variables w_sec, thl_sec, qw_sec, and qwthl_sec + +! call diag_moments(total_water,tke,tkh) + +! Second moment of vertical velocity. +! Note that Eq 6 in BK13 gives a different expression that is dependent on +! vertical gradient of grid scale vertical velocity + + do k=1,nzm + ku = k+1 + kd = k-1 + ka = ku + kb = k + if (k == 1) then + kd = k + kb = ka + elseif (k == nzm) then + ku = k + ka = kb + endif + do j=1,ny + do i=1,nx + if (tke(i,j,k) > zero) then +! wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & + wrk = half*(tkh(i,j,ka)*prnum(i,j,ka)+tkh(i,j,kb)*prnum(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & + * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) + w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) +! w_sec(i,j,k) = max(twoby3 * tke(i,j,k), zero) +! if(lprnt .and. i == ipr .and. k <40) write(0,*)' w_sec=',w_sec(i,j,k),' tke=r',tke(i,j,k),& +! ' tkh=',tkh(i,j,ka),tkh(i,j,kb),' w=',w(i,j,ku),w(i,j,kd),' prnum=',prnum(i,j,ka),prnum(i,j,kb) + else + w_sec(i,j,k) = zero + endif + enddo + enddo + enddo + + do k=2,nzm + + km1 = k - 1 + do j=1,ny + do i=1,nx + +! Use backward difference in the vertical, use averaged values of "return-to-isotropy" +! time scale and diffusion coefficient + + wrk1 = one / adzi(i,j,k) ! adzi(k) = (zl(k)-zl(km1)) +! wrk3 = max(tkh(i,j,k),pt01) * wrk1 + wrk3 = max(tkh(i,j,k),epsln) * wrk1 + + sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 + +! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 +! No rain, snow or graupel in pdf (Annig, 08/29/2018) + + wrk1 = hl(i,j,k) - hl(i,j,km1) & + + (qpl(i,j,k) - qpl(i,j,km1)) * fac_cond & + + (qpi(i,j,k) - qpi(i,j,km1)) * fac_sub + wthl_sec(i,j,k) = - wrk3 * wrk1 + +! SGS vertical flux of total water. Eq 2 in BK13 + + wrk2 = total_water(i,j,k) - total_water(i,j,km1) + wqw_sec(i,j,k) = - wrk3 * wrk2 + +! Second moment of liquid/ice water static energy. Eq 4 in BK13 + + thl_sec(i,j,k) = thl2tune * sm * wrk1 * wrk1 + +! Second moment of total water mixing ratio. Eq 3 in BK13 + + qw_sec(i,j,k) = qw2tune * sm * wrk2 * wrk2 + +! Covariance of total water mixing ratio and liquid/ice water static energy. +! Eq 5 in BK13 + + qwthl_sec(i,j,k) = qwthl2tune * sm * wrk1 * wrk2 + + enddo ! i loop + enddo ! j loop + enddo ! k loop + +! These would be at the surface - do we need them? + do j=1,ny + do i=1,nx +! wthl_sec(i,j,1) = wthl_sec(i,j,2) +! wqw_sec(i,j,1) = wqw_sec(i,j,2) + thl_sec(i,j,1) = thl_sec(i,j,2) + qw_sec(i,j,1) = qw_sec(i,j,2) + qwthl_sec(i,j,1) = qwthl_sec(i,j,2) + enddo + enddo + +! Diagnose the third moment of SGS vertical velocity + + call canuto() + +! Recover parameters of the subgrid PDF using diagnosed moments +! and calculate SGS cloudiness, condensation and it's effects on temeperature +! and moisture variables + + call assumed_pdf() + +contains + + subroutine tke_shoc() + +! This subroutine solves the TKE equation, +! Heavily based on SAM's tke_full.f90 by Marat Khairoutdinov + + real grd,betdz,Cee,lstarn, lstarp, bbb, omn, omp,qsatt,dqsat, smix, & + buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss,a_prod_bu_debug, buoy_sgs_debug, & + tscale1, wrk, wrk1, wtke, wtk2, rdtn, tkef2 + integer i,j,k,ku,kd,itr,k1 + + rdtn = one / dtn + + call tke_shear_prod(def2) ! Calculate shear production of TKE + +! Ensure values of TKE are reasonable + + do k=1,nzm + do j=1,ny + do i=1,nx + tke(i,j,k) = max(min_tke,tke(i,j,k)) + tkesbdiss(i,j,k) = zero +! tkesbshear(i,j,k) = zero +! tkesbbuoy(i,j,k) = zero + enddo + enddo + enddo + + call eddy_length() ! Find turbulent mixing length + call check_eddy() ! Make sure it's reasonable + + tkef2 = 1.0 - tkef1 + do k=1,nzm + ku = k+1 + kd = k + +! Cek = Ce * cefac + + if(k == 1) then + ku = 2 + kd = 2 +! Cek = Ces + elseif(k == nzm) then + ku = k + kd = k +! Cek = Ces + endif + + if (dis_opt > 0) then + do j=1,ny + do i=1,nx + wrk = (zl(i,j,k)-zi(i,j,1)) / adzl(i,j,1) + 1.5 + cek(i,j) = 1.0 + 2.0 / max((wrk*wrk - 3.3), 0.5) + enddo + enddo + else + if (k == 1) then + cek = ces * cesfac + else + cek = ce * cefac + endif + endif + + do j=1,ny + do i=1,nx + grd = adzl(i,j,k) ! adzl(k) = zi(k+1)-zi(k) + + +! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in +! assumed_pdf(). The value used here is from the previous time step + + a_prod_bu = ggr / thv(i,j,k) * wthv_sec(i,j,k) + +! If wthv_sec from subgrid PDF is not available use Brunt-Vaisalla frequency from eddy_length() + +!Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux +!Presumably it is more precise than BV freq. calculated in eddy_length()? + + buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,j,ku)+tkh(i,j,kd) + 0.0001) ! tkh is eddy thermal diffussivity + + +!Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) + + if (buoy_sgs <= zero) then + smix = grd + else + smix = min(grd,max(0.1*grd, 0.76*sqrt(tke(i,j,k)/(buoy_sgs+1.e-10)))) + endif + + ratio = smix/grd + Cee = Cek(i,j) * (pt19 + pt51*ratio) * max(one, sqrt(pcrit/prsl(i,j,k))) + +! TKE shear production term + a_prod_sh = half*(def2(i,j,ku)*tkh(i,j,ku)*prnum(i,j,ku) & + + def2(i,j,kd)*tkh(i,j,kd)*prnum(i,j,kd)) + + +! smixt (turb. mixing lenght) is calculated in eddy_length() +! Explicitly integrate TKE equation forward in time +! a_diss = Cee/smixt(i,j,k)*tke(i,j,k)**1.5 ! TKE dissipation term +! tke(i,j,k) = max(zero,tke(i,j,k)+dtn*(max(zero,a_prod_sh+a_prod_bu)-a_diss)) + +! Semi-implicitly integrate TKE equation forward in time + + wtke = tke(i,j,k) + wtk2 = wtke +! wrk = (dtn*Cee)/smixt(i,j,k) + wrk = (dtn*Cee) / smixt(i,j,k) + wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wrk1=',wrk1,& +! ' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,' dtn=',dtn,' smixt=',& +! smixt(i,j,k),' tkh=',tkh(i,j,ku),tkh(i,j,kd),' def2=',def2(i,j,ku),def2(i,j,kd)& +! ,' prnum=',prnum(i,j,ku),prnum(i,j,kd),' wthv_sec=',wthv_sec(i,j,k),' thv=',thv(i,j,k) + + do itr=1,nitr ! iterate for implicit solution + wtke = min(max(min_tke, wtke), max_tke) + a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term + wtke = wrk1 / (one+a_diss) + wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& +! ' a_diss=',a_diss,' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,& +! ' wrk1=',wrk1,' itr=',itr,' k=',k + + wtk2 = wtke + + enddo + + tke(i,j,k) = min(max(min_tke, wtke), max_tke) + a_diss = wrk*sqrt(tke(i,j,k)) + + tscale1 = (dtn+dtn) / a_diss ! corrected Eq 8 in BK13 -- tau = 2*tke/eps + + tkesbdiss(i,j,k) = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon + + +! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 + + if (buoy_sgs <= zero) then + isotropy(i,j,k) = min(max_eddy_dissipation_time_scale,tscale1) + else + isotropy(i,j,k) = min(max_eddy_dissipation_time_scale, & + tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) + endif + +! TKE budget terms + +! tkesbdiss(i,j,k) = a_diss +! tkesbshear(i,j,k) = a_prod_sh +! tkesbbuoy(i,j,k) = a_prod_bu +! tkesbbuoy_debug(i,j,k) = a_prod_bu_debug +! tkebuoy_sgs(i,j,k) = buoy_sgs + + enddo ! i loop + enddo ! j loop + enddo ! k +! + wrk = half * ck + do k=2,nzm + k1 = k - 1 + do j=1,ny + do i=1,nx + tkh(i,j,k) = min(tkhmax, wrk * (isotropy(i,j,k) * tke(i,j,k) & + + isotropy(i,j,k1) * tke(i,j,k1))) ! Eddy thermal diffusivity + enddo ! i + enddo ! j + enddo ! k + + + end subroutine tke_shoc + + + subroutine tke_shear_prod(def2) + +! Calculate TKE shear production term + + real, intent(out) :: def2(nx,ny,nzm) + + real rdzw, wrku, wrkv, wrkw + integer i,j,k,k1 + +! Calculate TKE shear production term at layer interface + + do k=2,nzm + k1 = k - 1 + do j=1,ny + do i=1,nx + rdzw = one / adzi(i,j,k) + wrku = (u(i,j,k)-u(i,j,k1)) * rdzw + wrkv = (v(i,j,k)-v(i,j,k1)) * rdzw +! wrkw = (w(i,j,k)-w(i,j,k1)) * rdzw + def2(i,j,k) = wrku*wrku + wrkv*wrkv !+ 2*wrkw(1) * wrkw(1) + enddo + enddo + enddo ! k loop + do j=1,ny + do i=1,nx +! def2(i,j,1) = def2(i,j,2) + def2(i,j,1) = (u(i,j,1)*u(i,j,1) + v(i,j,1)*v(i,j,1)) & + / (zl(i,j,1)*zl(i,j,1)) + enddo + enddo + + end subroutine tke_shear_prod + + subroutine eddy_length() + +! This subroutine computes the turbulent length scale based on a new +! formulation described in BK13 + +! Local variables + real wrk, wrk1, wrk2, wrk3 + integer i, j, k, kk, kl, ku, kb, kc, kli, kui + + do j=1,ny + do i=1,nx + cldarr(i,j) = zero + numer(i,j) = zero + denom(i,j) = zero + enddo + enddo + +! Find the length scale outside of clouds, that includes boundary layers. + + do k=1,nzm + do j=1,ny + do i=1,nx + +! Reinitialize the mixing length related arrays to zero +! smixt(i,j,k) = one ! shoc_mod module variable smixt + smixt(i,j,k) = epsln ! shoc_mod module variable smixt + brunt(i,j,k) = zero + +!Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) +!Outside of cloud, integrate from the surface to the cloud base +!Should the 'if' below check if the cloud liquid < a small constant instead? + + if (qcl(i,j,k)+qci(i,j,k) <= zero) then + tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) + numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 + denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 + else + cldarr(i,j) = one ! Take note of columns containing cloud. + endif + enddo + enddo + enddo + +! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) + do j=1,ny + do i=1,nx + if (denom(i,j) > zero .and. numer(i,j) > zero) then + l_inf(i,j) = min(0.1 * (numer(i,j)/denom(i,j)), 100.0) + else + l_inf(i,j) = 100.0 + endif + enddo + enddo + +!Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) + do k=1,nzm + + kb = k-1 + kc = k+1 + if (k == 1) then + kb = 1 + kc = 2 + thedz(:,:) = adzi(:,:,kc) + elseif (k == nzm) then + kb = nzm-1 + kc = nzm + thedz(:,:) = adzi(:,:,k) + else + thedz(:,:) = adzi(:,:,kc) + adzi(:,:,k) ! = (z(k+1)-z(k-1)) + endif + + do j=1,ny + do i=1,nx + +! vars module variable bet (=ggr/tv0) ; grid module variable adzi + + betdz = bet(i,j,k) / thedz(i,j) + + tkes = sqrt(tke(i,j,k)) + +! Compute local Brunt-Vaisalla frequency + + wrk = qcl(i,j,k) + qci(i,j,k) + if (wrk > zero) then ! If in the cloud + +! Find the in-cloud Brunt-Vaisalla frequency + + omn = qcl(i,j,k) / (wrk+1.e-20) ! Ratio of liquid water to total water + +! Latent heat of phase transformation based on relative water phase content +! fac_cond = lcond/cp, fac_fus = lfus/cp + + lstarn = fac_cond + (one-omn)*fac_fus + +! Derivative of saturation mixing ratio over water/ice wrt temp. based on relative water phase content + dqsat = omn * dtqsatw(tabs(i,j,k),prsl(i,j,k)) & + + (one-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) + +! Saturation mixing ratio over water/ice wrt temp based on relative water phase content + + qsatt = omn * qsatw(tabs(i,j,k),prsl(i,j,k)) & + + (one-omn) * qsati(tabs(i,j,k),prsl(i,j,k)) + +! liquid/ice moist static energy static energy divided by cp? + + bbb = (one + epsv*qsatt-wrk-qpl(i,j,k)-qpi(i,j,k) & + + 1.61*tabs(i,j,k)*dqsat) / (one+lstarn*dqsat) + +! Calculate Brunt-Vaisalla frequency using centered differences in the vertical + + brunt(i,j,k) = betdz*(bbb*(hl(i,j,kc)-hl(i,j,kb)) & + + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,j,k)) & + * (total_water(i,j,kc)-total_water(i,j,kb)) & + + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) + + else ! outside of cloud + +! Find outside-of-cloud Brunt-Vaisalla frequency +! Only unsaturated air, rain and snow contribute to virt. pot. temp. +! liquid/ice moist static energy divided by cp? + + bbb = one + epsv*qv(i,j,k) - qpl(i,j,k) - qpi(i,j,k) + brunt(i,j,k) = betdz*( bbb*(hl(i,j,kc)-hl(i,j,kb)) & + + epsv*tabs(i,j,k)*(total_water(i,j,kc)-total_water(i,j,kb)) & + + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) + endif + +! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. +! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. + + if (brunt(i,j,k) >= zero) then + brunt2(i,j,k) = brunt(i,j,k) + else + brunt2(i,j,k) = zero + endif + +! Calculate turbulent length scale in the boundary layer. +! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) + +! Keep the length scale adequately small near the surface following Blackadar (1984) +! Note that this is not documented in BK13 and was added later for SP-CAM runs + +! if (k == 1) then +! term = 600.*tkes +! smixt(i,j,k) = term + (0.4*zl(i,j,k)-term)*exp(-zl(i,j,k)*0.01) +! else + +! tscale is the eddy turnover time scale in the boundary layer and is +! an empirically derived constant + + if (tkes > zero .and. l_inf(i,j) > zero) then + wrk1 = one / (tscale*tkes*vonk*zl(i,j,k)) + wrk2 = one / (tscale*tkes*l_inf(i,j)) + wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,j,k) / tke(i,j,k) + wrk1 = sqrt(one / max(wrk1,1.0e-8)) * (one/0.3) +! smixt(i,j,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) + smixt(i,j,k) = min(max_eddy_length_scale, wrk1) + +! smixt(i,j,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,j,k))) & +! + (1./(tscale*tkes*l_inf(i,j)))+0.01*(brunt2(i,j,k)/tke(i,j,k)))))/0.3) +! else +! smixt(i,j,k) = zero + endif + +! endif + + enddo + + enddo + enddo + + +! Now find the in-cloud turbulence length scale +! See Eq. 13 in BK13 (Eq. 4.18 in Pete's disseration) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Remove after coupling to subgrid PDF. +!wthv_sec = -300/ggr*brunt*tk +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! determine cubed convective velocity scale (conv_vel2) inside the cloud + +! call conv_scale() ! inlining the relevant code + +! do j=1,ny +! do i=1,nx +! conv_vel2(i,j,1) = zero ! Convective velocity scale cubed +! enddo +! enddo + ! Integrate velocity scale in the vertical +! do k=2,nzm +! do j=1,ny +! do i=1,nx +! conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & +! + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) +! enddo +! enddo +! enddo + + do j=1,ny + do i=1,nx + + if (cldarr(i,j) == 1) then ! If there's a cloud in this column + + kl = 0 + ku = 0 + do k=2,nzm-3 + +! Look for the cloud base in this column +! thresh (=0) is a variable local to eddy_length(). Should be a module constant. + wrk = qcl(i,j,k) + qci(i,j,k) + if (wrk > thresh .and. kl == 0) then + kl = k + endif + +! Look for the cloud top in this column + if (wrk > thresh .and. qcl(i,j,k+1)+qci(i,j,k+1) <= thresh) then + ku = k +! conv_vel2 (Cubed convective velocity scale) is calculated in conv_scale() +! Use the value of conv_vel2 at the top of the cloud. +! conv_var = conv_vel2(i,j,k)**(oneb3) + endif + +! Compute the mixing length scale for the cloud layer that we just found +! if (kl > 0 .and. ku > 0 .and. ku-kl > 1) then + if (kl > 0 .and. ku > 0 .and. ku-kl > 0) then + +! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud + conv_var = zero + do kk=kl,ku + conv_var = conv_var+ 2.5*adzi(i,j,kk)*bet(i,j,kk)*wthv_sec(i,j,kk) + enddo + conv_var = conv_var ** oneb3 + + if (conv_var > 0) then ! If convective vertical velocity scale > 0 + + depth = (zl(i,j,ku)-zl(i,j,kl)) + adzl(i,j,kl) + + + do kk=kl,ku +! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) + +! wrk = conv_var/(depth*sqrt(tke(i,j,kk))) +! wrk = wrk * wrk + pt01*brunt2(i,j,kk)/tke(i,j,kk) + + wrk = conv_var/(depth*depth*sqrt(tke(i,j,kk))) & + + pt01*brunt2(i,j,kk)/tke(i,j,kk) + + smixt(i,j,kk) = min(max_eddy_length_scale, (one/0.3)*sqrt(one/wrk)) + + enddo + + endif ! If convective vertical velocity scale > 0 + kl = zero + ku = zero + endif ! if inside the cloud layer + + enddo ! k=2,nzm-3 + endif ! if in the cloudy column + enddo ! i=1,nx + enddo ! j=1,ny + + + end subroutine eddy_length + + + subroutine conv_scale() + +! This subroutine calculates the cubed convective velocity scale needed +! for the definition of the length scale in clouds +! See Eq. 16 in BK13 (Eq. 4.21 in Pete's dissertation) + + integer i, j, k + +!!!!!!!!! +!! A bug in formulation of conv_vel +! Obtain it by averaging conv_vel2 in the horizontal +!!!!!!!!!! + +! conv_vel(1)=zero ! Horizontally averaged convective velocity scale cubed + do j=1,ny + do i=1,nx + conv_vel2(i,j,1) = zero ! Convective velocity scale cubed + enddo + enddo +! Integrate velocity scale in the vertical + do k=2,nzm +! conv_vel(k)=conv_vel(k-1) + do j=1,ny + do i=1,nx +!********************************************************************** +!Do not include grid-scale contribution to convective velocity scale in GCM applications +! conv_vel(k)=conv_vel(k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+tvws(k)) +! conv_vel(k)=conv_vel(k)+2.5*adzi(i,j,k)*bet(i,j,k)*(tvws(k)) +!Do not include grid-scale contribution to convective velocity scale in GCM applications +! conv_vel2(i,j,k)=conv_vel2(i,j,k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+wthv_sec(i,j,k)) +!********************************************************************** + + conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & + + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) + enddo + enddo + enddo + + end subroutine conv_scale + + + subroutine check_eddy() + +! This subroutine checks eddy length values + + integer i, j, k, kb, ks, zend + real wrk +! real zstart, zthresh, qthresh + +! Temporary kludge for marine stratocumulus under very strong inversions at coarse resolution +! Placement until some explicity PBL top is put in +! Not used. +! zthresh = 100. +! qthresh = -6.0 + + do k=1,nzm + + if (k == nzm) then + kb = k + else + kb = k+1 + endif + + do j=1,ny + do i=1,nx + + wrk = 0.1*adzl(i,j,k) + ! Minimum 0.1 of local dz + smixt(i,j,k) = max(wrk, min(max_eddy_length_scale,smixt(i,j,k))) + +! If chracteristic grid dimension in the horizontal< 1000m, set lengthscale to +! be not larger that that. +! if (sqrt(dx*dy) .le. 1000.) smixt(i,j,k)=min(sqrt(dx*dy),smixt(i,j,k)) + + if (qcl(i,j,kb) == 0 .and. qcl(i,j,k) > 0 .and. brunt(i,j,k) > 1.e-4) then +!If just above the cloud top and atmosphere is stable, set to 0.1 of local dz + smixt(i,j,k) = wrk + endif + + enddo ! i + enddo ! j + enddo ! k + + end subroutine check_eddy + + subroutine canuto() + +! Subroutine impements an analytic expression for the third moment of SGS vertical velocity +! based on Canuto et at, 2001, JAS, 58, 1169-1172 (further referred to as C01) +! This allows to avoid having a prognostic equation for the third moment. +! Result is returned in a global variable w3 defined at the interface levels. + +! Local variables + integer i, j, k, kb, kc + + real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & + omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & + wrk, wrk1, wrk2, wrk3, avew +! cond, wrk, wrk1, wrk2, wrk3, avew +! +! See Eq. 7 in C01 (B.7 in Pete's dissertation) + real, parameter :: c=7.0, a0=0.52/(c*c*(c-2.)), a1=0.87/(c*c), & + a2=0.5/c, a3=0.6/(c*(c-2.)), a4=2.4/(3.*c+5.), & + a5=0.6/(c*(3.*c+5)) +!Moorthi a5=0.6/(c*(3.+5.*c)) + +! do k=1,nzm + do k=2,nzm + + kb = k-1 + kc = k+1 + +! if(k == 1) then +! kb = 1 +! kc = 2 +! do j=1,ny +! do i=1,nx +! thedz(i,j) = one / adzl(i,j,kc) +! thedz2(i,j) = thedz(i,j) +! enddo +! enddo +! elseif(k == nzm) then + if (k == nzm) then + kb = nzm-1 + kc = nzm + do j=1,ny + do i=1,nx + thedz(i,j) = one / adzi(i,j,k) + thedz2(i,j) = one / adzl(i,j,kb) + enddo + enddo + else + do j=1,ny + do i=1,nx + thedz(i,j) = one / adzi(i,j,k) + thedz2(i,j) = one / (adzl(i,j,k)+adzl(i,j,kb)) + enddo + enddo + endif + + + do j=1,ny + do i=1,nx + + iso = half*(isotropy(i,j,k)+isotropy(i,j,kb)) + isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared + buoy_sgs2 = isosqr*half*(brunt(i,j,k)+brunt(i,j,kb)) + bet2 = half*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared + + +! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) + + + avew = half*(w_sec(i,j,k)+w_sec(i,j,kb)) +!aab +! + wrk1 = bet2*iso + wrk2 = thedz2(i,j)*wrk1*wrk1*iso + wrk3 = thl_sec(i,j,kc) - thl_sec(i,j,kb) + + f0 = wrk2 * wrk1 * wthl_sec(i,j,k) * wrk3 + + wrk = wthl_sec(i,j,kc) - wthl_sec(i,j,kb) + + f1 = wrk2 * (wrk*wthl_sec(i,j,k) + half*avew*wrk3) + + wrk1 = bet2*isosqr + f2 = thedz(i,j)*wrk1*wthl_sec(i,j,k)*(w_sec(i,j,k)-w_sec(i,j,kb)) & + + (thedz2(i,j)+thedz2(i,j))*bet(i,j,k)*isosqr*wrk + + f3 = thedz2(i,j)*wrk1*wrk + thedz(i,j)*bet2*isosqr*(wthl_sec(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) + + wrk1 = thedz(i,j)*iso*avew + f4 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) + + f5 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb)) + + +! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) + + omega0 = a4 / (one-a5*buoy_sgs2) + omega1 = omega0 / (c+c) + omega2 = omega1*f3+(5./4.)*omega0*f4 + +! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) + + wrk1 = one / (one-(a1+a3)*buoy_sgs2) + wrk2 = one / (one-a3*buoy_sgs2) + X0 = wrk1 * (a2*buoy_sgs2*(one-a3*buoy_sgs2)) + Y0 = wrk2 * (two*a2*buoy_sgs2*X0) + X1 = wrk1 * (a0*f0+a1*f1+a2*(one-a3*buoy_sgs2)*f2) + Y1 = wrk2 * (two*a2*(buoy_sgs2*X1+(a0/a1)*f0+f1)) + +! Compute the A0, A1 terms, see Eq. 5d in C01 (B.5 in Pete's dissertation) + + AA0 = omega0*X0 + omega1*Y0 + AA1 = omega0*X1 + omega1*Y1 + omega2 + +! Finally, we have the third moment of w, see Eq. 4c in C01 (B.4 in Pete's dissertation) +! cond is an estimate of third moment from second oment - If the third moment is larger +! than the estimate - limit w3. + +!aab + +! Implemetation of the C01 approach in this subroutine is nearly complete +! (the missing part are Eqs. 5c and 5e which are very simple) +! therefore it's easy to diagnose other third order moments obtained in C01 using this code. + + enddo + enddo + enddo + do j=1,ny + do i=1,nx + w3(i,j,1) = w3(i,j,2) + enddo + enddo + + end subroutine canuto + + subroutine assumed_pdf() + +! Compute SGS buoyancy flux, SGS cloud fraction, and SGS condensation +! using assumed analytic double-gaussian PDF for SGS vertical velocity, +! moisture, and liquid/ice water static energy, based on the +! general approach of Larson et al 2002, JAS, 59, 3519-3539, +! and Golaz et al 2002, JAS, 59, 3540-3551 +! References in the comments in this code are given to +! the Appendix A of Pete Bogenschutz's dissertation. + +! Local variables + + integer i,j,k,ku,kd + real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2, cond_w + +! bastoeps = basetemp / epsterm + + +! Initialize for statistics + do k=1,nzm + wqlsb(k) = zero + wqisb(k) = zero + enddo + + DO k=1,nzm + + kd = k + ku = k + 1 +! if (k == nzm) ku = k + + DO j=1,ny + DO i=1,nx + +! Initialize cloud variables to zero + diag_qn = zero + diag_frac = zero + diag_ql = zero + diag_qi = zero + + pval = prsl(i,j,k) + pfac = pval * 1.0e-5 + pkap = pfac ** kapa + +! Read in liquid/ice static energy, total water mixing ratio, +! and vertical velocity to variables PDF needs + + thl_first = hl(i,j,k) + fac_cond*qpl(i,j,k) & + + fac_sub*qpi(i,j,k) + + qw_first = total_water(i,j,k) +! w_first = half*(w(i,j,kd)+w(i,j,ku)) + w_first = w(i,j,k) + + +! GET ALL INPUT VARIABLES ON THE SAME GRID +! Points to be computed with relation to thermo point +! Read in points that need to be averaged + + if (k < nzm) then + w3var = half*(w3(i,j,kd)+w3(i,j,ku)) + thlsec = max(zero, half*(thl_sec(i,j,kd)+thl_sec(i,j,ku)) ) + qwsec = max(zero, half*(qw_sec(i,j,kd)+qw_sec(i,j,ku)) ) + qwthlsec = half * (qwthl_sec(i,j,kd) + qwthl_sec(i,j,ku)) + wqwsec = half * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) + wthlsec = half * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) + else ! at the model top assuming zeros + w3var = half*w3(i,j,k) + thlsec = max(zero, half*thl_sec(i,j,k)) + qwsec = max(zero, half*qw_sec(i,j,k)) + qwthlsec = half * qwthl_sec(i,j,k) + wqwsec = half * wqw_sec(i,j,k) + wthlsec = half * wthl_sec(i,j,k) + endif + +! w3var = w3(i,j,k) +! thlsec = max(zero,thl_sec(i,j,k)) +! qwsec = max(zero,qw_sec(i,j,k)) +! qwthlsec = qwthl_sec(i,j,k) +! wqwsec = wqw_sec(i,j,k) +! wthlsec = wthl_sec(i,j,k) + +! Compute square roots of some variables so we don't have to do it again +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' w_sec=',w_sec(i,j,k),' k=',k + if (w_sec(i,j,k) > zero) then + sqrtw2 = sqrt(w_sec(i,j,k)) + else + sqrtw2 = zero + endif + if (thlsec > zero) then + sqrtthl = sqrt(thlsec) + else + sqrtthl = zero + endif + if (qwsec > zero) then + sqrtqt = sqrt(qwsec) + else + sqrtqt = zero + endif + + +! Find parameters of the double Gaussian PDF of vertical velocity + +! Skewness of vertical velocity +! Skew_w = w3var / w_sec(i,j,k)**(3./2.) +! Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi + + IF (w_sec(i,j,k) <= w_tol_sqd) THEN ! If variance of w is too small then + ! PDF is a sum of two delta functions + Skew_w = zero + w1_1 = w_first + w1_2 = w_first + w2_1 = zero + w2_2 = zero + aterm = half + onema = half + ELSE + +!aab + + Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi +! Proportionality coefficients between widths of each vertical velocity +! gaussian and the sqrt of the second moment of w + w2_1 = 0.4 + w2_2 = 0.4 + +! Compute realtive weight of the first PDF "plume" +! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 + + wrk = one - w2_1 + aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) + onema = one - aterm + + sqrtw2t = sqrt(wrk) + +! Eq. A.5-A.6 + wrk = sqrt(onema/aterm) + w1_1 = sqrtw2t * wrk + w1_2 = - sqrtw2t / wrk + + w2_1 = w2_1 * w_sec(i,j,k) + w2_2 = w2_2 * w_sec(i,j,k) + + ENDIF + +! Find parameters of the PDF of liquid/ice static energy + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thlsec=',thlsec,' w1_2=',w1_2,' w1_1=',w1_1,& +! ' thl_first=',thl_first,' k=',k,' wthlsec=',wthlsec,sqrtw2,sqrtthl + IF (thlsec <= thl_tol*thl_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN + thl1_1 = thl_first + thl1_2 = thl_first + thl2_1 = zero + thl2_2 = zero + sqrtthl2_1 = zero + sqrtthl2_2 = zero + ELSE + + corrtest1 = max(-one,min(one,wthlsec/(sqrtw2*sqrtthl))) + + thl1_1 = -corrtest1 / w1_2 ! A.7 + thl1_2 = -corrtest1 / w1_1 ! A.8 + + wrk1 = thl1_1 * thl1_1 + wrk2 = thl1_2 * thl1_2 + wrk3 = three * (one - aterm*wrk1 - onema*wrk2) + wrk4 = -skew_facw*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi +! wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi +! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 + wrk = three * (thl1_2-thl1_1) + if (wrk /= zero) then + thl2_1 = thlsec * min(100.,max(zero,( thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + thl2_2 = thlsec * min(100.,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + else + thl2_1 = zero + thl2_2 = zero + endif +! +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' sqrtthl=',sqrtthl,' thl_first=',thl_first,& +! ' thl1_2=',thl1_2,' corrtest1=',corrtest1,' w1_2=',w1_2,' w1_1=',w1_1 + + thl1_1 = thl1_1*sqrtthl + thl_first + thl1_2 = thl1_2*sqrtthl + thl_first + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' thl1_1=',thl1_1,' thl1_2=',thl1_2 + + sqrtthl2_1 = sqrt(thl2_1) + sqrtthl2_2 = sqrt(thl2_2) + + ENDIF + +! FIND PARAMETERS FOR TOTAL WATER MIXING RATIO + + IF (qwsec <= rt_tol*rt_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN + qw1_1 = qw_first + qw1_2 = qw_first + qw2_1 = zero + qw2_2 = zero + sqrtqw2_1 = zero + sqrtqw2_2 = zero + ELSE + + corrtest2 = max(-one,min(one,wqwsec/(sqrtw2*sqrtqt))) + + qw1_1 = - corrtest2 / w1_2 ! A.7 + qw1_2 = - corrtest2 / w1_1 ! A.8 + + tsign = abs(qw1_2-qw1_1) + +! Skew_qw = skew_facw*Skew_w + + IF (tsign > 0.4) THEN + Skew_qw = skew_facw*Skew_w + ELSEIF (tsign <= 0.2) THEN + Skew_qw = zero + ELSE + Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) + ENDIF + + wrk1 = qw1_1 * qw1_1 + wrk2 = qw1_2 * qw1_2 + wrk3 = three * (one - aterm*wrk1 - onema*wrk2) + wrk4 = Skew_qw - aterm*wrk1*qw1_1 - onema*wrk2*qw1_2 + wrk = three * (qw1_2-qw1_1) + + if (wrk /= zero) then + qw2_1 = qwsec * min(100.,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + qw2_2 = qwsec * min(100.,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + else + qw2_1 = zero + qw2_2 = zero + endif +! + qw1_1 = qw1_1*sqrtqt + qw_first + qw1_2 = qw1_2*sqrtqt + qw_first + + sqrtqw2_1 = sqrt(qw2_1) + sqrtqw2_2 = sqrt(qw2_2) + + ENDIF + +! CONVERT FROM TILDA VARIABLES TO "REAL" VARIABLES + + w1_1 = w1_1*sqrtw2 + w_first + w1_2 = w1_2*sqrtw2 + w_first + +! FIND WITHIN-PLUME CORRELATIONS + + testvar = aterm*sqrtqw2_1*sqrtthl2_1 + onema*sqrtqw2_2*sqrtthl2_2 + + IF (testvar == 0) THEN + r_qwthl_1 = zero + ELSE + r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first) & + -onema*(qw1_2-qw_first)*(thl1_2-thl_first))/testvar)) ! A.12 + ENDIF + +! BEGIN TO COMPUTE CLOUD PROPERTY STATISTICS + +! wrk1 = gamaz(i,j,k) - fac_cond * qpl(i,j,k) - fac_sub * qpi(i,j,k) +! Tl1_1 = thl1_1 - wrk1 +! Tl1_2 = thl1_2 - wrk1 + + Tl1_1 = thl1_1 - gamaz(i,j,k) + Tl1_2 = thl1_2 - gamaz(i,j,k) + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' Tl1_1=',Tl1_1,' Tl1_2=',Tl1_2,& +! ' wrk1=',wrk1,' thl1_1=',thl1_1,' thl1_2=',thl1_2,' qpl=',qpl(i,j,k),' qpi=',qpi(i,j,k) + +! Now compute qs + + esval1_1 = zero + esval2_1 = zero + eps_ss1 = eps + eps_ss2 = eps + om1 = one + +! Partition based on temperature for the first plume + + IF (Tl1_1 >= tbgmax) THEN + esval1_1 = min(fpvsl(Tl1_1), pval) +! esval1_1 = esatw(Tl1_1) + lstarn1 = lcond + ELSE IF (Tl1_1 <= tbgmin) THEN + esval1_1 = min(fpvsi(Tl1_1), pval) +! esval1_1 = esati(Tl1_1) + lstarn1 = lsub + eps_ss1 = eps * supice + ELSE + esval1_1 = min(fpvsl(Tl1_1), pval) + esval2_1 = min(fpvsi(Tl1_1), pval) +! esval1_1 = esatw(Tl1_1) +! esval2_1 = esati(Tl1_1) + om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) + lstarn1 = lcond + (one-om1)*lfus + eps_ss2 = eps * supice + + ENDIF + qs1 = om1 * eps_ss1*esval1_1/(pval-0.378*esval1_1) & + + (one-om1) * eps_ss2*esval2_1/(pval-0.378*esval2_1) + +! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) + beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 + + +! Are the two plumes equal? If so then set qs and beta +! in each column to each other to save computation + IF (Tl1_1 == Tl1_2) THEN + qs2 = qs1 + beta2 = beta1 + ELSE + + esval1_2 = zero + esval2_2 = zero + eps_ss1 = eps + eps_ss2 = eps + om2 = one + + IF (Tl1_2 >= tbgmax) THEN + esval1_2 = min(fpvsl(Tl1_2), pval) +! esval1_2 = esatw(Tl1_2) + lstarn2 = lcond + ELSE IF (Tl1_2 <= tbgmin) THEN + esval1_2 = min(fpvsi(Tl1_2), pval) +! esval1_2 = esati(Tl1_2) + lstarn2 = lsub + eps_ss1 = eps * supice + ELSE + esval1_2 = min(fpvsl(Tl1_2), pval) + esval2_2 = min(fpvsi(Tl1_2), pval) +! esval1_2 = esatw(Tl1_2) +! esval2_2 = esati(Tl1_2) + om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) + lstarn2 = lcond + (one-om2)*lfus + eps_ss2 = eps * supice + ENDIF + + qs2 = om2 * eps_ss1*esval1_2/(pval-0.378*esval1_2) & + + (one-om2) * eps_ss2*esval2_2/(pval-0.378*esval2_2) + +! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 + beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 + + ENDIF + + qs1 = qs1 * rhc(i,j,k) + qs2 = qs2 * rhc(i,j,k) + +! Now compute cloud stuff - compute s term + + cqt1 = one / (one+beta1*qs1) ! A.19 + wrk = qs1 * (one+beta1*qw1_1) * cqt1 + s1 = qw1_1 - wrk ! A.17 + cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 + + wrk1 = cthl1 * cthl1 + wrk2 = cqt1 * cqt1 +! std_s1 = sqrt(max(zero,wrk1*thl2_1+wrk2*qw2_1-2.*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) + std_s1 = sqrt(max(zero, wrk1*thl2_1+wrk2*qw2_1 & + - two*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) + + qn1 = zero + C1 = zero + + IF (std_s1 > zero) THEN + wrk = s1 / (std_s1*sqrt2) + C1 = max(zero, min(one, half*(one+erf(wrk)))) ! A.15 + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& +! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1,' k=',k + +! IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 + qn1 = max(zero, s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk)) ! A.16 + ELSEIF (s1 > zero) THEN + C1 = one + qn1 = s1 + ENDIF + +! now compute non-precipitating cloud condensate + +! If two plumes exactly equal, then just set many of these +! variables to themselves to save on computation. + IF (qw1_1 == qw1_2 .and. thl2_1 == thl2_2 .and. qs1 == qs2) THEN + s2 = s1 + cthl2 = cthl1 + cqt2 = cqt1 + std_s2 = std_s1 + C2 = C1 + qn2 = qn1 + ELSE + + cqt2 = one / (one+beta2*qs2) + wrk = qs2 * (one+beta2*qw1_2) * cqt2 + s2 = qw1_2 - wrk + cthl2 = wrk*cqt2*cpolv*beta2*pkap + wrk1 = cthl2 * cthl2 + wrk2 = cqt2 * cqt2 +! std_s2 = sqrt(max(zero,wrk1*thl2_2+wrk2*qw2_2-2.*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) + std_s2 = sqrt(max(zero, wrk1*thl2_2+wrk2*qw2_2 & + - two*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) + + qn2 = zero + C2 = zero + + IF (std_s2 > zero) THEN + wrk = s2 / (std_s2*sqrt2) + C2 = max(zero, min(one, half*(one+erf(wrk)))) +! IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) + qn2 = max(zero, s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk)) + ELSEIF (s2 > zero) THEN + C2 = one + qn2 = s2 + ENDIF + + ENDIF + +! finally, compute the SGS cloud fraction + diag_frac = aterm*C1 + onema*C2 + + om1 = max(zero, min(one, (Tl1_1-tbgmin)*a_bg)) + om2 = max(zero, min(one, (Tl1_2-tbgmin)*a_bg)) + + qn1 = min(qn1,qw1_1) + qn2 = min(qn2,qw1_2) + + ql1 = qn1*om1 + ql2 = qn2*om2 + + qi1 = qn1 - ql1 + qi2 = qn2 - ql2 + +! if (lprnt .and. i == ipr .and. k<40) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& +! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k,' tl1=',tl1_1,tl1_2,' om1=',om1,'om2=',om2& +! ,' tbgmin=',tbgmin,'a_bg=',a_bg + + + diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,j,k)) + diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) + diag_qi = diag_qn - diag_ql + + +! Update temperature variable based on diagnosed cloud properties + om1 = max(zero, min(one, (tabs(i,j,k)-tbgmin)*a_bg)) + lstarn1 = lcond + (one-om1)*lfus + tabs(i,j,k) = hl(i,j,k) - gamaz(i,j,k) + fac_cond*(diag_ql+qpl(i,j,k)) & + + fac_sub *(diag_qi+qpi(i,j,k)) & + + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating + +! if (lprnt .and. i == ipr .and. k < 40) write(0,*)' tabsout=',tabs(ipr,1,k),' k=',k& +! ,' hl=',hl(i,j,k),' gamaz=',gamaz(i,j,k),' diag_ql=',diag_ql,' qpl=',qpl(i,j,k)& +! ,' diag_qi=',diag_qi,' qpi=',qpi(i,j,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& +! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 +! Update moisture fields + +! Update ncpl and ncpi Anning Cheng 03/11/2016 +! ncpl(i,j,k) = diag_ql/max(qc(i,j,k),1.e-10)*ncpl(i,j,k) +! The following commneted by Moorthi on April 26, 2017 to test blowing up +! ncpl(i,j,k) = (1.0-diag_ql/max(qc(i,j,k),1.e-10)) * ncpl(i,j,k) +! ncpi(i,j,k) = (1.0-diag_qi/max(qi(i,j,k),1.e-10)) * ncpi(i,j,k) + qc(i,j,k) = diag_ql + qi(i,j,k) = diag_qi + qwv(i,j,k) = total_water(i,j,k) - diag_qn + cld_sgs(i,j,k) = diag_frac + + +! Compute the liquid water flux + wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) + wqis = aterm * ((w1_1-w_first)*qi1) + onema * ((w1_2-w_first)*qi2) + +! Compute statistics for the fluxes so we don't have to save these variables + wqlsb(k) = wqlsb(k) + wqls + wqisb(k) = wqisb(k) + wqis + +! diagnostic buoyancy flux. Includes effects from liquid water, ice +! condensate, liquid & ice precipitation +! wrk = epsv * basetemp + wrk = epsv * thv(i,j,k) + + bastoeps = onebeps * thv(i,j,k) + + if (k < nzm) then + wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & + + (fac_cond-bastoeps)*wqls & + + (fac_sub-bastoeps) *wqis & + + ((lstarn1/cp)-thv(i,j,k))*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + else + wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & + + (fac_cond-bastoeps)*wqls & + + (fac_sub-bastoeps) *wqis & + + ((lstarn1/cp)-thv(i,j,k))*half*wqp_sec(i,j,k) + endif + +! wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & +! + (fac_cond-bastoeps)*wqls & +! + (fac_sub-bastoeps)*wqis & +! + ((lstarn1/cp)-basetemp)*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + + ENDDO + ENDDO + ENDDO + + + end subroutine assumed_pdf + + +! Saturation vapor pressure and mixing ratio subroutines +! Based on Flatau et al (1992), J. App. Met., 31, 1507-1513 +! Code by Marat Khairoutdinov + + + real function esatw(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 6.11239921, 0.443987641, 0.142986287e-1, & + 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & + 0.640689451e-10, -0.952447341e-13,-0.976195544e-15/ + real dt + dt = max(-80.,t-273.16) + esatw = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + end function esatw + + real function qsatw(t,p) +! implicit none + real t ! temperature (K) + real p ! pressure (Pa) + real esat +! esat = fpvs(t) + esat = fpvsl(t) + qsatw = 0.622 * esat/max(esat,p-0.378*esat) +! esat = esatw(t) +! qsatw = 0.622 * esat/max(esat,p-esat) + end function qsatw + + + real function esati(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 6.11147274, 0.503160820, 0.188439774e-1, & + 0.420895665e-3, 0.615021634e-5, 0.602588177e-7, & + 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ + real dt +! real esatw + if(t > 273.15) then + esati = esatw(t) + else if(t.gt.185.) then + dt = t-273.16 + esati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + else ! use some additional interpolation below 184K + dt = max(-100.,t-273.16) + esati = 0.00763685 + dt*(0.000151069+dt*7.48215e-07) + endif + end function esati + + real function qsati(t,p) + real t ! temperature (K) + real p ! pressure (Pa) + real esat !,esati +! esat = fpvs(t) + esat = fpvsi(t) + qsati = 0.622 * esat/max(esat,p-0.378*esat) +! esat = esati(t) +! qsati = 0.622 * esat/max(esat,p-esat) + end function qsati + + real function dtesatw(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 0.443956472, 0.285976452e-1, 0.794747212e-3, & + 0.121167162e-4, 0.103167413e-6, 0.385208005e-9, & + -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/ + real dt + dt = max(-80.,t-273.16) + dtesatw = a0 + dt* (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + end function dtesatw + + real function dtqsatw(t,p) + real t ! temperature (K) + real p ! pressure (Pa) +! real dtesatw + dtqsatw = 100.0*0.622*dtesatw(t)/p + end function dtqsatw + + real function dtesati(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 0.503223089, 0.377174432e-1, 0.126710138e-2, & + 0.249065913e-4, 0.312668753e-6, 0.255653718e-8, & + 0.132073448e-10, 0.390204672e-13, 0.497275778e-16/ + real dt +! real dtesatw + if(t > 273.15) then + dtesati = dtesatw(t) + else if(t > 185.) then + dt = t-273.16 + dtesati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + else ! use additional interpolation below 185K + dt = max(-100.,t-273.16) + dtesati = 0.0013186 + dt*(2.60269e-05+dt*1.28676e-07) + endif + end function dtesati + + + real function dtqsati(t,p) + real t ! temperature (K) + real p ! pressure (Pa) +! real dtesati + dtqsati = 100.0*0.622*dtesati(t)/p + end function dtqsati + +end subroutine shoc_work + +end module shoc diff --git a/physics/gscond.f b/physics/gscond.f new file mode 100644 index 000000000..bfc6115fa --- /dev/null +++ b/physics/gscond.f @@ -0,0 +1,526 @@ +!> \file gscond.f +!! This file contains the subroutine that calculates grid-scale +!! condensation and evaporation for use in Zhao and Carr (1997) +!! \cite zhao_and_carr_1997 scheme. + +!> This module contains the CCPP-compliant zhao_carr_gscond scheme. + module zhaocarr_gscond + contains + + +! \brief Brief description of the subroutine +! +!> \section arg_table_gscond_init Argument Table +!! + subroutine zhaocarr_gscond_init + end subroutine zhaocarr_gscond_init + +! \brief Brief description of the subroutine +! +!> \section arg_table_gscond_finalize Argument Table +!! + subroutine zhaocarr_gscond_finalize + end subroutine zhaocarr_gscond_finalize + +!> \defgroup condense GFS gscond Main +!> @{ +!! This subroutine computes grid-scale condensation and evaporation of +!! cloud condensate. +!! +#if 0 +!> \section arg_table_zhaocarr_gscond_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|----------------------------------------------------------------|-------------------------------------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!! | prsl | air_pressure | layer mean air pressure | Pa | 2 | real | kind_phys | in | F | +!! | ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | clw1 | ice_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of ice water in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | in | F | +!! | clw2 | cloud_condensed_water_mixing_ratio_convective_transport_tracer | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) in the convectively transported tracer array | kg kg-1 | 2 | real | kind_phys | in | F | +!! | cwm | cloud_condensed_water_mixing_ratio_updated_by_physics | moist cloud condensed water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | +!! | t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | inout | F | +!! | tp | air_temperature_two_time_steps_back | air temperature two time steps back | K | 2 | real | kind_phys | inout | F | +!! | qp | water_vapor_specific_humidity_two_time_steps_back | water vapor specific humidity two time steps back | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | psp | surface_air_pressure_two_time_steps_back | surface air pressure two time steps back | Pa | 1 | real | kind_phys | inout | F | +!! | tp1 | air_temperature_at_previous_time_step | air temperature at previous time step | K | 2 | real | kind_phys | inout | F | +!! | qp1 | water_vapor_specific_humidity_at_previous_time_step | water vapor specific humidity at previous time step | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | psp1 | surface_air_pressure_at_previous_time_step | surface air surface pressure at previous time step | Pa | 1 | real | kind_phys | inout | F | +!! | u | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | +!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!! | ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif +!> \section general_gscond GFS gscond Scheme General Algorithm +!! -# Calculate ice-water identification number \f$IW\f$ in order to make a distinction between +!! cloud water and cloud ice (table2 of Zhao and Carr (1997) \cite zhao_and_carr_1997). +!! -# Calculate the changes in \f$t\f$, \f$q\f$ and \f$p\f$ due to all the processes except microphysics. +!! -# Calculate cloud evaporation rate (\f$E_c\f$, eq. 19 of Zhao and Carr (1997)\cite zhao_and_carr_1997). +!! -# Calculate cloud condensation rate (\f$C_g\f$, eq.8 of Zhao and Carr (1997)\cite zhao_and_carr_1997). +!! -# Update \f$t\f$, \f$q\f$, \f$cwm\f$ due to cloud evaporation and condensation processes. +!> \section Zhao-Carr_cond_detailed GFS gscond Scheme Detailed Algorithm +!> @{ + subroutine zhaocarr_gscond_run (im,ix,km,dt,dtf,prsl,ps,q,clw1 & + &, clw2, cwm, t, tp, qp, psp & + &, tp1, qp1, psp1, u, lprnt, ipr, errmsg, errflg) + +! +! ****************************************************************** +! * * +! * subroutine for grid-scale condensation & evaporation * +! * for the mrf model at ncep. * +! * * +! ****************************************************************** +! * * +! * created by: q. zhao jan. 1995 * +! * modified by: h.-l. pan sep. 1998 * +! * modified by: s. moorthi aug. 1998, 1999, 2000 * +! * * +! * references: * +! * * +! ****************************************************************** +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, psat => con_psat, hvap => con_hvap, grav => con_g + &, hfus => con_hfus, ttp => con_ttp, rd => con_rd + &, cp => con_cp, eps => con_eps, epsm1 => con_epsm1 + &, rv => con_rv +! use namelist_def, only: nsdfi,fhdfi + implicit none +! +! Interface variables + integer, intent(in) :: im, ix, km, ipr + real(kind=kind_phys), intent(in) :: dt, dtf + real(kind=kind_phys), intent(in) :: prsl(ix,km), ps(im) + real(kind=kind_phys), intent(inout) :: q(ix,km) + real(kind=kind_phys), intent(in) :: clw1(ix,km), clw2(ix,km) + real(kind=kind_phys), intent(out) :: cwm(ix,km) + real(kind=kind_phys), intent(inout) :: t(ix,km) & + &, tp(ix,km), qp(ix,km), psp(im) & + &, tp1(ix,km), qp1(ix,km), psp1(im) + real(kind=kind_phys), intent(in) :: u(im,km) + logical, intent(in) :: lprnt +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! Local variables + real (kind=kind_phys) h1 + &, d00, elwv, eliv + &, epsq + &, r, cpr, rcp + parameter (h1=1.e0, d00=0.e0 + &, elwv=hvap, eliv=hvap+hfus + &, epsq=2.e-12, r=rd + &, cpr=cp*r, rcp=h1/cp) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 +! + real (kind=kind_phys) qi(im), qint(im), ccrik, e0 + &, cond, rdt, us, cclimit, climit + &, tmt0, tmt15, qik, cwmik + &, ai, qw, u00ik, tik, pres, pp0, fi + &, at, aq, ap, fiw, elv, qc, rqik + &, rqikk, tx1, tx2, tx3, es, qs + &, tsq, delq, condi, cone0, us00, ccrik1 + &, aa, ab, ac, ad, ae, af, ag + &, el2orc, albycp +! real (kind=kind_phys) vprs(im) + integer iw(im,km), i, k, iwik +! + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +!-----------------GFS interstitial in driver ---------------------------- + do i = 1,im + do k= 1,km + cwm(i,k) = clw1(i,k)+clw2(i,k) + enddo + enddo +!-----------------prepare constants for later uses----------------- +! + el2orc = hvap*hvap / (rv*cp) + albycp = hvap / cp +! write(0,*)' in gscond im=',im,' ix=',ix +! + rdt = h1/dt + us = h1 + cclimit = 1.0e-3 + climit = 1.0e-20 +! + do i = 1, im + iw(i,km) = d00 + enddo +! +! check for first time step +! +! if (tp(1,1) < 1.) then +! do k = 1, km +! do i = 1, im +! tp(i,k) = t(i,k) +! qp(i,k) = max(q(i,k),epsq) +! tp1(i,k) = t(i,k) +! qp1(i,k) = max(q(i,k),epsq) +! enddo +! enddo +! do i = 1, im +! psp(i) = ps(i) +! psp1(i) = ps(i) +! enddo +! endif +! +!************************************************************* +!> -# Begining of grid-scale condensation/evaporation loop (start of +!! k-loop, i-loop) +!************************************************************* +! +! do k = km-1,2,-1 + do k = km,1,-1 +! vprs(:) = 0.001 * fpvs(t(:,k)) ! fpvs in pa +!----------------------------------------------------------------------- +!------------------qw, qi and qint-------------------------------------- + do i = 1, im + tmt0 = t(i,k)-273.16 + tmt15 = min(tmt0,cons_m15) + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) +! +! ai = 0.008855 +! bi = 1.0 +! if (tmt0 .lt. -20.0) then +! ai = 0.007225 +! bi = 0.9674 +! end if +! +! the global qsat computation is done in pa + pres = prsl(i,k) +! +! qw = vprs(i) + qw = min(pres, fpvs(t(i,k))) +! + qw = eps * qw / (pres + epsm1 * qw) + qw = max(qw,epsq) +! qi(i) = qw *(bi+ai*min(tmt0,cons_0)) +! qint(i) = qw *(1.-0.00032*tmt15*(tmt15+15.)) + qi(i) = qw + qint(i) = qw +! if (tmt0 .le. -40.) qint(i) = qi(i) + +!> -# Compute ice-water identification number IW. +!!\n The distinction between cloud water and cloud ice is made by the +!! cloud identification number IW, which is zero for cloud water and +!! unity for cloud ice (Table 2 in Zhao and Carr (1997) +!! \cite zhao_and_carr_1997): +!! - All clouds are defined to consist of liquid water below the +!! freezing level (\f$T\geq 0^oC\f$) and of ice particles above the +!! \f$T=-15^oC\f$ level. +!! - In the temperature region between \f$-15^oC\f$ and \f$0^oC\f$, +!! clouds may be composed of liquid water or ice. If there are cloud +!! ice particles above this point at the previous or current time step, +!! or if the cloud at this point at the previous time step consists of +!! ice particles, then the cloud substance at this point is considered +!! to be ice particles because of the cloud seeding effect and the +!! memory of its content. Otherwise, all clouds in this region are +!! considered to contain supercooled cloud water. + +!-------------------ice-water id number iw------------------------------ + if(tmt0.lt.-15.0) then + u00ik = u(i,k) + fi = qik - u00ik*qi(i) + if(fi > d00.or.cwmik > climit) then + iw(i,k) = 1 + else + iw(i,k) = 0 + end if + end if +! + if(tmt0.ge.0.0) then + iw(i,k) = 0 + end if +! + if (tmt0 < 0.0 .and. tmt0 >= -15.0) then + iw(i,k) = 0 + if (k < km) then + if (iw(i,k+1) == 1 .and. cwmik > climit) iw(i,k) = 1 + endif + end if + enddo +!> -# Condensation and evaporation of cloud +!--------------condensation and evaporation of cloud-------------------- + do i = 1, im +!> - Compute the changes in t, q and p (\f$A_{t}\f$,\f$A_{q}\f$ and +!! \f$A_{p}\f$) caused by all the processes except grid-scale +!! condensation and evaporation. +!!\f[ +!! A_{t}=(t-tp)/dt +!!\f] +!!\f[ +!! A_{q}=(q-qp)/dt +!!\f] +!!\f[ +!! A_{p}=(prsl-\frac{prsl}{ps} \times psp)/dt +!!\f] +!------------------------at, aq and dp/dt------------------------------- + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) + iwik = iw(i,k) + u00ik = u(i,k) + tik = t(i,k) + pres = prsl(i,k) + pp0 = (pres / ps(i)) * psp(i) + at = (tik-tp(i,k)) * rdt + aq = (qik-qp(i,k)) * rdt + ap = (pres-pp0) * rdt +!> - Calculate the saturation specific humidity \f$q_{s}\f$ and the +!! relative humidity \f$f\f$ using IW. +!----------------the satuation specific humidity------------------------ + fiw = float(iwik) + elv = (h1-fiw)*elwv + fiw*eliv + qc = (h1-fiw)*qint(i) + fiw*qi(i) +! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i) +!----------------the relative humidity---------------------------------- + if(qc.le.1.0e-10) then + rqik=d00 + else + rqik = qik/qc + endif + +!> - According to Sundqvist et al. (1989) \cite sundqvist_et_al_1989, +!! estimate cloud fraction \f$b\f$ at a grid point from relative +!! humidity \f$f\f$ using the equation +!!\f[ +!! b=1-\left ( \frac{f_{s}-f}{f_{s}-u} \right )^{1/2} +!!\f] +!! for \f$f>u\f$; and \f$b=0\f$ for \f$f1.0\times10^{-3}\f$, condense water vapor +!! into cloud condensate (\f$C_{g}\f$). +!!\n Using \f$q=fq_{s}\f$, \f$q_{s}=\epsilon e_{s}/p\f$, and the +!! Clausius-Clapeyron equation \f$de_{s}/dT=\epsilon Le_{s}/RT^{2}\f$, +!! where \f$q_{s}\f$ is the saturation specific humidity,\f$e_{s}\f$ +!! is the saturation vapor pressure, \f$R\f$ is the specific gas +!! constant for dry air, \f$f\f$ is the relative humidity, and +!! \f$\epsilon=0.622\f$, the expression for \f$C_{g}\f$ has the form +!!\f[ +!! C_{g}=\frac{M-q_{s}f_{t}}{1+(f\epsilon L^{2}q_{s}/RC_{p}T^{2})}+E_{c} +!!\f] +!! where +!!\f[ +!! M=A_{q}-\frac{f\epsilon Lq_{s}}{RT^{2}}A_{t}+\frac{fq_{s}}{p}A_{p} +!!\f] +!! To close the system, an equation for the relative humidity tendency +!! \f$f_{t}\f$ was derived by Sundqvist et al.(1989) +!! \cite sundqvist_et_al_1989 using the hypothesis that the quantity +!! \f$M+E_{c}\f$ is divided into one part,\f$bM\f$,which condenses +!! in the already cloudy portion of a grid square, and another part, +!! \f$(1-b)M+E_{c}\f$,which is used to increase the relative humidity +!! of the cloud-free portion and the cloudiness in the square. The +!! equation is written as +!!\f[ +!! f_{t}=\frac{2(1-b)(f_{s}-u)[(1-b)M+E_{c}]}{2q_{s}(1-b)(f_{s}-u)+cwm/b} +!!\f] +!! - Check and correct if over condensation occurs. +!! - Update t, q and cwm (according to Eqs(6) and (7) in Zhao and Carr (1997) +!! \cite zhao_and_carr_1997) +!!\f[ +!! cwm=cwm+(C_{g}-E_{c})\times dt +!!\f] +!!\f[ +!! q=q-(C_{g}-E_{c})\times dt +!!\f] +!!\f[ +!! t=t+\frac{L}{C_{p}}(C_{g}-E_{c})\times dt +!!\f] +!!\n where \f$L\f$ is the latent heat of condensation/deposition, and +!! \f$C_{p}\f$ is the specific heat of air at constant pressure. + +!----------------cloud cover ratio ccrik-------------------------------- + if (rqik .lt. u00ik) then + ccrik = d00 + elseif(rqik.ge.us) then + ccrik = us + else + rqikk = min(us,rqik) + ccrik = h1-sqrt((us-rqikk)/(us-u00ik)) + endif +!-----------correct ccr if it is too small in large cwm regions-------- +! if(ccrik.ge.0.01.and.ccrik.le.0.2.and +! & .cwmik.ge.0.2e-3) then +! ccrik=min(1.0,cwmik*1.0e3) +! end if +!---------------------------------------------------------------------- +! if no cloud exists then evaporate any existing cloud condensate +!----------------evaporation of cloud water----------------------------- + e0 = d00 + if (ccrik <= cclimit.and. cwmik > climit) then +! +! first iteration - increment halved +! + tx1 = tik + tx3 = qik +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = 0.5 * (qs - tx3) * tsq / (tsq + el2orc * qs) +! + tx2 = delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! second iteration +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = (qs - tx3) * tsq / (tsq + el2orc * qs) +! + tx2 = tx2 + delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! third iteration +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = (qs - tx3) * tsq / (tsq + el2orc * qs) + tx2 = tx2 + delq +! + e0 = max(tx2*rdt, cons_0) +! if (lprnt .and. i .eq. ipr .and. k .eq. 34) +! & print *,' tx2=',tx2,' qc=',qc,' u00ik=',u00ik,' rqik=',rqik +! &,' cwmik=',cwmik,' e0',e0 + +! e0 = max(qc*(u00ik-rqik)*rdt, cons_0) + e0 = min(cwmik*rdt, e0) + e0 = max(cons_0,e0) + end if +! if cloud cover > 0.2 condense water vapor in to cloud condensate +!-----------the eqs. for cond. has been reorganized to reduce cpu------ + cond = d00 +! if (ccrik .gt. 0.20 .and. qc .gt. epsq) then + if (ccrik .gt. cclimit .and. qc .gt. epsq) then + us00 = us - u00ik + ccrik1 = 1.0 - ccrik + aa = eps*elv*pres*qik + ab = ccrik*ccrik1*qc*us00 + ac = ab + 0.5*cwmik + ad = ab * ccrik1 + ae = cpr*tik*tik + af = ae * pres + ag = aa * elv + ai = cp * aa + cond = (ac-ad)*(af*aq-ai*at+ae*qik*ap)/(ac*(af+ag)) +!-----------check & correct if over condensation occurs----------------- + condi = (qik -u00ik *qc*1.0)*rdt + cond = min(cond, condi) +!----------check & correct if supersatuation is too high---------------- +! qtemp=qik-max(0.,(cond-e0))*dt +! if(qc.le.1.0e-10) then +! rqtmp=0.0 +! else +! rqtmp=qtemp/qc +! end if +! if(rqtmp.ge.1.10) then +! cond=(qik-1.10*qc)*rdt +! end if +!----------------------------------------------------------------------- + cond = max(cond, d00) +!-------------------update of t, q and cwm------------------------------ + end if + cone0 = (cond-e0) * dt + cwm(i,k) = cwm(i,k) + cone0 +! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0 +! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k +! &,' cwm=',cwm(i,k) + t(i,k) = t(i,k) + elv*rcp*cone0 + q(i,k) = q(i,k) - cone0 + enddo ! end of i-loop! + enddo ! end of k-loop! +! +!********************************************************************* +!> -# End of the condensation/evaporation loop (end of i-loop,k-loop). +!********************************************************************* +! +!> -# Store \f$t\f$, \f$q\f$, \f$ps\f$ for next time step. + + if (dt > dtf+0.001) then ! three time level + do k = 1, km + do i = 1, im + tp(i,k) = tp1(i,k) + qp(i,k) = qp1(i,k) +! + tp1(i,k) = t(i,k) + qp1(i,k) = max(q(i,k),epsq) + enddo + enddo + do i = 1, im + psp(i) = psp1(i) + psp1(i) = ps(i) + enddo + else ! two time level scheme - tp1, qp1, psp1 not used + do k = 1, km +! write(0,*)' in gscond k=',k,' im=',im,' km=',km + do i = 1, im +! write(0,*)' in gscond i=',i + tp(i,k) = t(i,k) + qp(i,k) = max(q(i,k),epsq) +! qp(i,k) = q(i,k) + tp1(i,k) = tp(i,k) + qp1(i,k) = qp(i,k) + enddo + enddo + do i = 1, im + psp(i) = ps(i) + psp1(i) = ps(i) + enddo + endif +!----------------------------------------------------------------------- + return + end subroutine zhaocarr_gscond_run +!> @} +!> @} + end module zhaocarr_gscond diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 new file mode 100644 index 000000000..554a00e74 --- /dev/null +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -0,0 +1,362 @@ +!> \file module_mynnsfc_wrapper.F90 +!! Contains all of the code related to running the MYNN surface layer scheme + + MODULE mynnsfc_wrapper + + contains + + subroutine mynnsfc_wrapper_init () + end subroutine mynnsfc_wrapper_init + + subroutine mynnsfc_wrapper_finalize () + end subroutine mynnsfc_wrapper_finalize + +!>\defgroup gsd_mynn_sfc GSD MYNN Surface Layer Scheme Module +!> \brief This scheme (1) performs pre-mynnsfc work, (2) runs the mynn sfc layer scheme, and (3) performs post-mynnsfc work +#if 0 +!! \section arg_table_mynnsfc_wrapper_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |---------------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | +!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | +!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | u | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | v | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | t3d | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qvsh | water_vapor_specific_humidity | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | in | F | +!! | qc | cloud_condensed_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of cloud water (condensate) | kg kg-1 | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | exner | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | tsq | t_prime_squared | temperature fluctuation squared | K2 | 2 | real | kind_phys | in | F | +!! | qsq | q_prime_squared | water vapor fluctuation squared | kg2 kg-2 | 2 | real | kind_phys | in | F | +!! | cov | t_prime_q_prime | covariance of temperature and moisture | K kg kg-1 | 2 | real | kind_phys | in | F | +!! | el_pbl | mixing_length | mixing length in meters | m | 2 | real | kind_phys | in | F | +!! | Sh3D | stability_function_for_heat | stability function for heat | none | 2 | real | kind_phys | in | F | +!! | QC_BL | subgrid_cloud_mixing_ratio_pbl | subgrid cloud cloud mixing ratio from PBL scheme | kg kg-1 | 2 | real | kind_phys | in | F | +!! | CLDFRA_BL | subgrid_cloud_fraction_pbl | subgrid cloud fraction from PBL scheme | frac | 2 | real | kind_phys | in | F | +!! | ps | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | PBLH | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | +!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | +!! | tsk | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | in | F | +!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | in | F | +!! | snowd | surface_snow_thickness_water_equivalent | water equivalent snow depth over land | mm | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | inout | F | +!! | ust | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | +!! | ustm | surface_friction_velocity_drag | friction velocity isolated for momentum only | m s-1 | 1 | real | kind_phys | inout | F | +!! | zol | surface_stability_parameter | monin obukhov surface stability parameter | none | 1 | real | kind_phys | inout | F | +!! | mol | theta_star | temperature flux divided by ustar (temperature scale) | K | 1 | real | kind_phys | inout | F | +!! | rmol | reciprocal_of_obukhov_length | one over obukhov length | m-1 | 1 | real | kind_phys | inout | F | +!! | fm | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity parameter for momentum | none | 1 | real | kind_phys | inout | F | +!! | fh | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity parameter for heat | none | 1 | real | kind_phys | inout | F | +!! | fm10 | Monin-Obukhov_similarity_function_for_momentum_at_10m | Monin-Obukhov similarity parameter for momentum | none | 1 | real | kind_phys | inout | F | +!! | fh2 | Monin-Obukhov_similarity_function_for_heat_at_2m | Monin-Obukhov similarity parameter for heat | none | 1 | real | kind_phys | inout | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | inout | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | inout | F | +!! | ch | surface_drag_wind_speed_for_momentum_in_air | momentum exchange coefficient | m s-1 | 1 | real | kind_phys | inout | F | +!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | inout | F | +!! | QFX | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | inout | F | +!! | lh | surface_latent_heat | latent heating at the surface (pos = up) | W m-2 | 1 | real | kind_phys | inout | F | +!! | flhc | surface_exchange_coefficient_for_heat | surface exchange coefficient for heat | W m-2 K-1 | 1 | real | kind_phys | inout | F | +!! | flqc | surface_exchange_coefficient_for_moisture | surface exchange coefficient for moisture | kg m-2 s-1 | 1 | real | kind_phys | inout | F | +!! | u10 | x_wind_at_10m | 10 meter u wind speed | m s-1 | 1 | real | kind_phys | inout | F | +!! | v10 | y_wind_at_10m | 10 meter v wind speed | m s-1 | 1 | real | kind_phys | inout | F | +!! | th2 | potential_temperature_at_2m | 2 meter potential temperature | K | 1 | real | kind_phys | inout | F | +!! | t2 | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | inout | F | +!! | q2 | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | +!! | wstar | surface_wind_enhancement_due_to_convection | surface wind enhancement due to convection | m s-1 | 1 | real | kind_phys | inout | F | +!! | chs2 | surface_exchange_coefficient_for_heat_at_2m | exchange coefficient for heat at 2 meters | m s-1 | 1 | real | kind_phys | inout | F | +!! | cqs2 | surface_exchange_coefficient_for_moisture_at_2m | exchange coefficient for moisture at 2 meters | m s-1 | 1 | real | kind_phys | inout | F | +!! | cda | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | +!! | cka | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | inout | F | +!! | bl_mynn_cloudpdf | cloudpdf | flag to determine which cloud PDF to use | flag | 0 | integer | | in | F | +!! | icloud_bl | couple_sgs_clouds_to_radiation_flag | flag for coupling sgs clouds to radiation | flag | 0 | integer | | in | F | +!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | none | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif +!###=================================================================== +SUBROUTINE mynnsfc_wrapper_run( & + & ix,im,levs, & + & iter,flag_init,flag_restart, & + & delt,dx, & + & u, v, t3d, qvsh, qc, prsl, phii,& + & exner, tsq, qsq, cov, sh3d, & + & el_pbl, qc_bl, cldfra_bl, & + & ps, PBLH, slmsk, TSK, & + & QSFC, snowd, & + & zorl,UST,USTM, ZOL,MOL,RMOL, & + & fm, fh, fm10, fh2, WSPD, br, ch,& + & HFLX, QFX, LH, FLHC, FLQC, & + & U10, V10, TH2, T2, Q2, & + & wstar, CHS2, CQS2, & + & cda, cka, stress, & +! & CP, G, ROVCP, R, XLV, & +! & SVP1, SVP2, SVP3, SVPT0, & +! & EP1,EP2,KARMAN, & + & icloud_bl, bl_mynn_cloudpdf, & + & lprnt, errmsg, errflg ) + + +! should be moved to inside the mynn: + use machine , only : kind_phys +! use funcphys, only : fpvs + + use physcons, only : cp => con_cp, & + & g => con_g, & + & r_d => con_rd, & + & r_v => con_rv, & + & cpv => con_cvap, & + & cliq => con_cliq, & + & Cice => con_csol, & + & rcp => con_rocp, & + & XLV => con_hvap, & + & XLF => con_hfus, & + & EP_1 => con_fvirt, & + & EP_2 => con_eps + + USE module_sf_mynn, only : SFCLAY_mynn + +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- +! --- constant parameters: +! real(kind=kind_phys), parameter :: rvovrd = r_v/r_d + real(kind=kind_phys), parameter :: karman = 0.4 +! real(kind=kind_phys), parameter :: XLS = 2.85E6 +! real(kind=kind_phys), parameter :: p1000mb = 100000. + real(kind=kind_phys), parameter :: SVP1 = 0.6112 + real(kind=kind_phys), parameter :: SVP2 = 17.67 + real(kind=kind_phys), parameter :: SVP3 = 29.65 + real(kind=kind_phys), parameter :: SVPT0 = 273.15 + +!------------------------------------------------------------------- +!For WRF: +!------------------------------------------------------------------- +! USE module_model_constants, only: & +! &karman, g, p1000mb, & +! &cp, r_d, r_v, rcp, xlv, xlf, xls, & +! &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & +! &cpv, cliq, cice + +!------------------------------------------------------------------- +!For reference +! REAL , PARAMETER :: karman = 0.4 +! REAL , PARAMETER :: g = 9.81 +! REAL , PARAMETER :: r_d = 287. +! REAL , PARAMETER :: cp = 7.*r_d/2. +! REAL , PARAMETER :: r_v = 461.6 +! REAL , PARAMETER :: cpv = 4.*r_v +! REAL , PARAMETER :: cliq = 4190. +! REAL , PARAMETER :: Cice = 2106. +! REAL , PARAMETER :: rcp = r_d/cp +! REAL , PARAMETER :: XLS = 2.85E6 +! REAL , PARAMETER :: XLV = 2.5E6 +! REAL , PARAMETER :: XLF = 3.50E5 +! REAL , PARAMETER :: p1000mb = 100000. +! REAL , PARAMETER :: rvovrd = r_v/r_d +! REAL , PARAMETER :: SVP1 = 0.6112 +! REAL , PARAMETER :: SVP2 = 17.67 +! REAL , PARAMETER :: SVP3 = 29.65 +! REAL , PARAMETER :: SVPT0 = 273.15 +! REAL , PARAMETER :: EP_1 = R_v/R_d-1. +! REAL , PARAMETER :: EP_2 = R_d/R_v + + REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & + &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2, g_inv=1/g + + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! NAMELIST OPTIONS (INPUT): + INTEGER, INTENT(IN) :: & + & bl_mynn_cloudpdf, & + & icloud_bl + +!MISC CONFIGURATION OPTIONS + INTEGER, PARAMETER :: & + & spp_pbl = 0, & + & isftcflx = 0, & + & iz0tlnd = 0, & + & isfflx = 1 + +!MYNN-1D + REAL :: delt + INTEGER :: im, ix, levs + INTEGER :: iter, k, i, itimestep + LOGICAL :: flag_init,flag_restart,lprnt + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & + & IMS,IME,JMS,JME,KMS,KME, & + & ITS,ITE,JTS,JTE,KTS,KTE + +!MYNN-3D + real(kind=kind_phys), dimension(im,levs+1) :: phii + real(kind=kind_phys), dimension(im,levs) :: & + & exner, PRSL, & + & u, v, t3d, qvsh, qc, & + & Sh3D, EL_PBL, EXCH_H, & + & qc_bl, cldfra_bl, & + & Tsq, Qsq, Cov + !LOCAL + real(kind=kind_phys), dimension(im,levs) :: & + & dz, rho, th, qv, & + & pattern_spp_pbl + +!MYNN-2D + real(kind=kind_phys), dimension(im) :: & + & dx, pblh, slmsk, tsk, qsfc, ps, & + & zorl, ust, ustm, hflx, qfx, br, wspd, snowd, & + & FLHC, FLQC, U10, V10, TH2, T2, Q2, & + & CHS2, CQS2, rmol, zol, mol, ch, & + & fm, fh, fm10, fh2, & + & lh, cda, cka, stress, wstar + !LOCAL + real, dimension(im) :: & + & qcg, hfx, znt, ts, snowh, psim, psih, & + & chs, ck, cd, mavail, regime, xland, GZ1OZ0 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lprnt) then + write(0,*)"==============================================" + write(0,*)"in mynn surface layer wrapper..." + write(0,*)"flag_init=",flag_init + write(0,*)"flag_restart=",flag_restart + write(0,*)"iter=",iter + endif + + ! If initialization is needed and mynnsfc_wrapper is called + ! in a subcycling loop, then test for (flag_init==.T. .and. iter==1); + ! initialization in sfclay_mynn is triggered by itimestep == 1 + ! DH* TODO: Use flag_restart to distinguish which fields need + ! to be initialized and which are read from restart files + if (flag_init.and.iter==1) then + itimestep = 1 + else + itimestep = 2 + endif + + !prep MYNN-only variables + do k=1,levs + do i=1,im + dz(i,k)=(phii(i,k+1) - phii(i,k))*g_inv + th(i,k)=t3d(i,k)/exner(i,k) + !qc(i,k)=MAX(qgrs(i,k,ntcw),0.0) + qv(i,k)=qvsh(i,k)/(1.0 - qvsh(i,k)) + rho(i,k)=prsl(i,k)/(r_d*t3d(i,k)) !gt0(i,k)) + pattern_spp_pbl(i,k)=0.0 + enddo + enddo + do i=1,im + if (slmsk(i)==1. .or. slmsk(i)==2.)then !sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 !but land/water = (1/2) in SFCLAY_mynn + else + xland(i)=2.0 + endif +! ust(i) = sqrt(stress(i)) + !ch(i)=0.0 + HFX(i)=hflx(i)*rho(i,1)*cp + !QFX(i)=evap(i) + !wstar(i)=0.0 + qcg(i)=0.0 + snowh(i)=snowd(i)*800. !mm -> m + znt(i)=zorl(i)*0.01 !cm -> m? + ts(i)=tsk(i)/exner(i,1) !theta +! qsfc(i)=qss(i) +! ps(i)=pgr(i) +! wspd(i)=wind(i) + mavail(i)=1.0 !???? + enddo + + if (lprnt) then + write(0,*)"CALLING SFCLAY_mynn; input:" + print*,"T:",t3d(1,1),t3d(1,2),t3d(1,3) + print*,"TH:",th(1,1),th(1,2),th(1,3) + print*,"rho:",rho(1,1),rho(1,2),rho(1,3) + print*,"u:",u(1,1:3) + !print*,"qv:",qv(1,1:3,1) + print*,"p:",prsl(1,1)," snowh=",snowh(1) + print*,"dz:",dz(1,1)," qsfc=",qsfc(1) + print*,"rmol:",rmol(1)," ust:",ust(1) + print*,"Tsk:",tsk(1)," Thetasurf:",ts(1) + print*,"HFX:",hfx(1)," qfx",qfx(1) + print*,"qsfc:",qsfc(1)," ps:",ps(1) + print*,"wspd:",wspd(1),"br=",br(1) + print*,"znt:",znt(1)," delt=",delt + print*,"im=",im," levs=",levs + print*,"flag_init=",flag_init !," ntcw=",ntcw!," ntk=",ntk + print*,"flag_restart=",flag_restart !," ntcw=",ntcw!," ntk=",ntk + print*,"iter=",iter + !print*,"ncld=",ncld," ntrac(gq0)=",ntrac + print*,"zlvl(1)=",dz(1,1)*0.5 + print*,"PBLH=",pblh(1)," xland=",xland(1) + endif + + + CALL SFCLAY_mynn( & + u3d=u,v3d=v,t3d=t3d,qv3d=qv,p3d=prsl,dz8w=dz, & + CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv, & + PSFCPA=ps,CHS=chs,CHS2=chs2,CQS2=cqs2, & + ZNT=znt,UST=ust,PBLH=pblh,MAVAIL=mavail, & + ZOL=zol,MOL=mol,REGIME=regime,psim=psim,psih=psih, & + psix=fm,psit=fh,psix10=fm10,psit2=fh2, & +! fm=psix,fh=psit,fm10=psix10,fh2=psit2, & + XLAND=xland,HFX=hfx,QFX=qfx,LH=lh,TSK=tsk, & + FLHC=flhc,FLQC=flqc,QSFC=qsfc,RMOL=rmol, & + U10=u10,V10=v10,TH2=th2,T2=t2,Q2=q2,SNOWH=snowh, & + GZ1OZ0=GZ1OZ0,WSPD=wspd,BR=br,ISFFLX=isfflx,DX=dx, & + SVP1=svp1,SVP2=svp2,SVP3=svp3,SVPT0=svpt0, & + EP1=ep_1,EP2=ep_2,KARMAN=karman, & + itimestep=itimestep,ch=ch, & + th3d=th,pi3d=exner,qc3d=qc,rho3d=rho, & + tsq=tsq,qsq=qsq,cov=cov,sh3d=sh3d,el_pbl=el_pbl, & + qcg=qcg,wstar=wstar, & + icloud_bl=icloud_bl,qc_bl=qc_bl,cldfra_bl=cldfra_bl, & + spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl, & + ids=1,ide=im, jds=1,jde=1, kds=1,kde=levs, & + ims=1,ime=im, jms=1,jme=1, kms=1,kme=levs, & + its=1,ite=im, jts=1,jte=1, kts=1,kte=levs, & + ustm=ustm, ck=ck, cka=cka, cd=cd, cda=cda, & + isftcflx=isftcflx, iz0tlnd=iz0tlnd, & + bl_mynn_cloudpdf=bl_mynn_cloudpdf ) + + + ! POST MYNN SURFACE LAYER (INTERSTITIAL) WORK: + do i = 1, im + hflx(i)=hfx(i)/(rho(i,1)*cp) + !QFX(i)=evap(i) + zorl(i)=znt(i)*100. !m -> cm + stress(i) = ust(i)**2 + enddo + + + if (lprnt) then + print* + print*,"finished with mynn_surface layer; output:" + print*,"xland=",xland(1)," cda=",cda(1) + print*,"rmol:",rmol(1)," ust:",ust(1) + print*,"Tsk:",tsk(1)," Thetasurf:",ts(1) + print*,"HFX:",hfx(1)," qfx",qfx(1) + print*,"qsfc:",qsfc(1)," ps:",ps(1) + print*,"wspd:",wspd(1)," br=",br(1) + print*,"znt:",znt(1),"pblh:",pblh(1) + print*,"FLHC=",FLHC(1)," CHS=",CHS(1) + print* + endif + + + END SUBROUTINE mynnsfc_wrapper_run + +!###================================================================= + +END MODULE mynnsfc_wrapper diff --git a/physics/moninshoc.f b/physics/moninshoc.f new file mode 100644 index 000000000..05473db6c --- /dev/null +++ b/physics/moninshoc.f @@ -0,0 +1,607 @@ +!> \file moninshoc.f +!! Contains most of the SHOC PBL/shallow convection scheme. + +!> This module contains the CCPP-compliant SHOC scheme. + module moninshoc + + contains + + subroutine moninshoc_init () + end subroutine moninshoc_init + + subroutine moninshoc_finalize () + end subroutine moninshoc_finalize + +!!!!! ========================================================== !!!!! +! subroutine 'moninshoc' computes pbl height and applies vertical diffusion +! using the coefficient provided by the SHOC scheme (from previous step) +! 2015-05-04 - Shrinivas Moorthi - original version based on monin +! 2018-03-21 - Shrinivas Moorthi - fixed a bug related to tke vertical diffusion +! and gneralized the tke location in tracer array +! 2018-03-23 - Shrinivas Moorthi - used twice the momentum diffusion coefficient +! for tke as in Deardorff (1980) - added tridi1 +! +!> \section arg_table_moninshoc_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | +!! | ncnd | number_of_tracers_for_cloud_condensate | number of tracers for cloud condensate | count | 0 | integer | | in | F | +!! | dv | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | du | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | tau | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | rtg | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers due to vertical diffusion in PBL scheme | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | u1 | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | v1 | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | t1 | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | q1 | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | +!! | tkh | atmosphere_heat_diffusivity_from_shoc | diffusivity for heat from the SHOC scheme | m2 s-1 | 2 | real | kind_phys | in | F | +!! | prnum | prandtl_number | turbulent Prandtl number | none | 2 | real | kind_phys | inout | F | +!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | +!! | psk | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at the surface interface | none | 1 | real | kind_phys | in | F | +!! | rbsoil | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | u10m | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10m | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | fm | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | fh | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | tsea | surface_skin_temperature | surface skin temperature | K | 1 | real | kind_phys | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | spd1 | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | del | air_pressure_difference_between_midlayers | pres(k) - pres(k+1) | Pa | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prslk | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | delt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dkt | atmosphere_heat_diffusivity | diffusivity for heat | m2 s-1 | 2 | real | kind_phys | out | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | kinver | index_of_highest_temperature_inversion | index of highest temperature inversion | index | 1 | integer | | in | F | +!! | xkzm_m | atmosphere_momentum_diffusivity_background | background value of momentum diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | +!! | xkzm_h | atmosphere_heat_diffusivity_background | background value of heat diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | +!! | xkzm_s | diffusivity_background_sigma_level | sigma level threshold for background diffusivity | none | 0 | real | kind_phys | in | F | +!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!! | ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | grav | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine moninshoc_run (ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, + & u1,v1,t1,q1,tkh,prnum,ntke, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,delt, + & dusfc,dvsfc,dtsfc,dqsfc,dkt,hpbl, + & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr,me, + & grav, rd, cp, hvap, fv, + & errmsg,errflg) +! + use machine , only : kind_phys + use funcphys , only : fpvs + + implicit none +! +! arguments +! + logical, intent(in) :: lprnt + integer, intent(in) :: ix, im, + & km, ntrac, ntcw, ncnd, ntke, ipr, me + integer, dimension(im), intent(in) :: kinver + + real(kind=kind_phys), intent(in) :: delt, + & xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), intent(in) :: grav, + & rd, cp, hvap, fv + real(kind=kind_phys), dimension(im), intent(in) :: psk, + & rbsoil, zorl, u10m, v10m, fm, fh, tsea, heat, evap, stress, spd1 + real(kind=kind_phys), dimension(ix,km), intent(in) :: u1, v1, + & t1, tkh, del, prsl, phil, prslk + real(kind=kind_phys), dimension(ix,km+1), intent(in) :: prsi, phii + real(kind=kind_phys), dimension(ix,km,ntrac), intent(in) :: q1 + + real(kind=kind_phys), dimension(im,km), intent(inout) :: du, dv, + & tau, prnum + real(kind=kind_phys), dimension(im,km,ntrac), intent(inout) :: rtg + + integer, dimension(im), intent(out) :: kpbl + real(kind=kind_phys), dimension(im), intent(out) :: dusfc, + & dvsfc, dtsfc, dqsfc, hpbl + real(kind=kind_phys), dimension(im,km-1), intent(out) :: dkt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! locals +! + integer i,is,k,kk,km1,kmpbl,kp1, ntloc +! + logical pblflg(im), sfcflg(im), flg(im) + + real(kind=kind_phys), dimension(im) :: phih, phim + &, rbdn, rbup, sflux, z0, crb, zol, thermal + &, beta, tx1 +! + real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad + &, dt2odel + real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au + &, dku, rdzt +! + real(kind=kind_phys) zi(im,km+1), a2(im,km*(ntrac+1)) +! + real(kind=kind_phys) dsdz2, dsdzq, dsdzt, dsig, dt2, rdt + &, dtodsd, dtodsu, rdz, tem, tem1 + &, ttend, utend, vtend, qtend + &, spdk2, rbint, ri, zol1, robn, bvf2 +! + real(kind=kind_phys), parameter :: zolcr=0.2, + & zolcru=-0.5, rimin=-100., sfcfrac=0.1, + & crbcon=0.25, crbmin=0.15, crbmax=0.35, + & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, + & aphi5=5., aphi16=16., f0=1.e-4 + &, dkmin=0.0, dkmax=1000. +! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 + &, prmin=0.25, prmax=4.0 + &, vk=0.4, cfac=6.5 + real(kind=kind_phys) :: gravi, cont, conq, conw, gocp + + gravi = 1.0/grav + cont = cp/grav + conq = hvap/grav + conw = 1.0/grav + gocp = grav/cp + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +!----------------------------------------------------------------------- +! +! compute preliminary variables +! + if (ix < im) stop +! +! if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) + dt2 = delt + rdt = 1. / dt2 + km1 = km - 1 + kmpbl = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + dt2odel(i,k) = dt2 / del(i,k) + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +! + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + prnum(i,k) = 1.0 + enddo + enddo +! Setup backgrond diffision + do i=1,im + prnum(i,km) = 1.0 + tx1(i) = 1.0 / prsi(i,1) + enddo + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity for heat and momentum + tem1 = 1.0 - prsi(i,k+1) * tx1(i) + tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) + xkzo(i,k) = xkzm_h * tem1 + xkzmo(i,k) = xkzm_m * tem1 + endif + enddo + enddo +! if (lprnt) then +! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) +! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! endif +! +! diffusivity in the inversion layer is set to be xkzminv (m^2/s) +! +! do k = 1,kmpbl +! do i=1,im +! if(zi(i,k+1) > 250.) then +! tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) +! if(tem1 > 1.e-5) then +! xkzo(i,k) = min(xkzo(i,k),xkzminv) +! endif +! endif +! enddo +! enddo +! +! + do i = 1,im + z0(i) = 0.01 * zorl(i) + kpbl(i) = 1 + hpbl(i) = zi(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do k = 1,km + do i=1,im + tx1(i) = 0.0 + enddo + do kk=1,ncnd + do i=1,im + tx1(i) = tx1(i) + max(q1(i,k,ntcw+kk-1), qlmin) + enddo + enddo + do i = 1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-tx1(i)) + enddo + enddo +! +! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + beta(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! +! compute the pbl height +! +! write(0,*)' IN moninbl u10=',u10m(1:5),' v10=',v10m(1:5) + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) +! + if(pblflg(i)) then + thermal(i) = thvx(i,1) + crb(i) = crbcon + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = max(1.0, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = max(min(0.16 * (tem1 ** (-0.18)), crbmax), crbmin) + endif + enddo + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) + rbup(i) = (thvx(i,k)-thermal(i))*phil(i,k) + & / (thvx(i,1)*spdk2) + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(kpbl(i) > 1) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + else + hpbl(i) = zl(i,1) + kpbl(i) = 1 + endif + enddo +! +! compute similarity parameters +! + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then +! phim(i) = (1.-aphi16*zol1)**(-1./4.) +! phih(i) = (1.-aphi16*zol1)**(-1./2.) + tem = 1.0 / max(1. - aphi16*zol1, 1.0e-8) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + enddo +! +! enhance the pbl height by considering the thermal excess +! + do i=1,im + flg(i) = .true. + if (pblflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) + rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k) + & / (thvx(i,1)*spdk2) + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if (pblflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) + endif + if (k > 1) then + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + if(kpbl(i) <= 1) then + pblflg(i) = .false. + endif + else + pblflg(i) = .false. + endif + endif + if (pblflg(i)) then + tem = phih(i)/phim(i) + cfac*vk*sfcfrac + else + tem = phih(i)/phim(i) + endif + prnum(i,1) = min(prmin,max(prmax,tem)) + enddo +! + do i = 1, im + if(zol(i) > zolcr) then + kpbl(i) = 1 + endif + enddo +! +! compute Prandtl number above boundary layer +! + do k = 1, km1 + kp1 = k + 1 + do i=1,im + if(k >= kpbl(i)) then + rdz = rdzt(i,k) + tem = u1(i,k) - u1(i,kp1) + tem1 = v1(i,k) - v1(i,kp1) + tem = (tem*tem + tem1*tem1) * rdz * rdz + bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz + & / (t1(i,k)+t1(i,kp1)) + ri = max(bvf2/tem,rimin) + if(ri < 0.) then ! unstable regime + prnum(i,kp1) = 1.0 + else + prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) + endif + elseif (k > 1) then + prnum(i,kp1) = prnum(i,1) + endif +! +! prnum(i,kp1) = 1.0 + prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) + tem = tkh(i,kp1) * prnum(i,kp1) + dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) + dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k)) + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture +! + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo +! if (lprnt) write(0,*)' a1=',a1(ipr,1),' beta=',beta(ipr) +! &,' heat=',heat(ipr), ' t1=',t1(ipr,1) + + ntloc = 1 + if(ntrac > 1) then + is = 0 + do k = 2, ntrac + if (k /= ntke) then + ntloc = ntloc + 1 + is = is + km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + endif + enddo + endif +! + do k = 1,km1 + kp1 = k + 1 + do i = 1,im + dtodsd = dt2odel(i,k) + dtodsu = dt2odel(i,kp1) + dsig = prsl(i,k)-prsl(i,kp1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + ad(i,k) = ad(i,k)-au(i,k) + ad(i,kp1) = 1.-al(i,k) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k) + dtodsd*dsdzt + a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt + a2(i,kp1) = q1(i,kp1,1) +! + enddo + enddo +! + if(ntrac > 1) then + is = 0 + do kk = 2, ntrac + if (kk /= ntke) then + is = is + km + do k = 1, km1 + kp1 = k + 1 + do i = 1, im + a2(i,kp1+is) = q1(i,kp1,kk) + enddo + enddo + endif + enddo + endif +! +! solve tridiagonal problem for heat and moisture +! + call tridin(im,km,ntloc,al,ad,au,a1,a2,au,a1,a2) + +! +! recover tendencies of heat and moisture +! + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1)) * rdt + tau(i,k) = tau(i,k) + ttend +! if(lprnt .and. i==ipr .and. k<11) write(0,*)' tau=',tau(ipr,k) +! &,' ttend=',ttend,' a1=',a1(ipr,k),' t1=',t1(ipr,k) + rtg(i,k,1) = rtg(i,k,1) + qtend + dtsfc(i) = dtsfc(i) + cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i) + conq*del(i,k)*qtend + enddo + enddo + if(ntrac > 1) then + is = 0 + do kk = 2, ntrac + if (kk /= ntke) then + is = is + km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk) + qtend + enddo + enddo + endif + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo +! + do k = 1,km1 + kp1 = k + 1 + do i=1,im + dtodsd = dt2odel(i,k) + dtodsu = dt2odel(i,kp1) + dsig = prsl(i,k)-prsl(i,kp1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + ad(i,k) = ad(i,k) - au(i,k) + ad(i,kp1) = 1.0 - al(i,k) + a1(i,kp1) = u1(i,kp1) + a2(i,kp1) = v1(i,kp1) +! + enddo + enddo + + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) +! +! recover tendencies of momentum +! + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + enddo + enddo +! + if (ntke > 0) then ! solve tridiagonal problem for momentum and tke +! +! compute tridiagonal matrix elements for tke +! + do i=1,im + ad(i,1) = 1.0 + a1(i,1) = q1(i,1,ntke) + enddo +! + do k = 1,km1 + kp1 = k + 1 + do i=1,im + dtodsd = dt2odel(i,k) + dtodsu = dt2odel(i,kp1) + dsig = prsl(i,k)-prsl(i,kp1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*(rdz+rdz) + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + ad(i,k) = ad(i,k) - au(i,k) + ad(i,kp1) = 1.0 - al(i,k) + a1(i,kp1) = q1(i,kp1,ntke) + enddo + enddo + + call tridi1(im,km,al,ad,au,a1,au,a1) +! + do k = 1, km ! recover tendencies of tke + do i = 1, im + qtend = (a1(i,k)-q1(i,k,ntke))*rdt + rtg(i,k,ntke) = rtg(i,k,ntke) + qtend + enddo + enddo + endif +! + return + end subroutine moninshoc_run + + end module moninshoc diff --git a/physics/ozphys.f b/physics/ozphys.f new file mode 100644 index 000000000..4acf87107 --- /dev/null +++ b/physics/ozphys.f @@ -0,0 +1,202 @@ +!> \file ozphys.f +!! This file is ozone sources and sinks (previous version). + + +!> This module contains the CCPP-compliant Ozone photochemistry scheme. + module ozphys + + contains + +! \brief Brief description of the subroutine +! +!> \section arg_table_ozphys_init Argument Table +!! + subroutine ozphys_init() + end subroutine ozphys_init + +! \brief Brief description of the subroutine +! +!> \section arg_table_ozphys_finalize Argument Table +!! + subroutine ozphys_finalize() + end subroutine ozphys_finalize + + +!>\defgroup GFS_ozphys GFS ozphys Main +!! \brief The operational GFS currently parameterizes ozone production and +!! destruction based on monthly mean coefficients (\c global_o3prdlos.f77) provided by Naval +!! Research Laboratory through CHEM2D chemistry model +!! (McCormack et al. (2006) \cite mccormack_et_al_2006). +!! \section arg_table_ozphys_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|---------------------------------------------------------------------------|----------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | +!! | ko3 | vertical_dimension_of_ozone_forcing_data | number of vertical layers in ozone forcing data | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | oz | ozone_concentration_updated_by_physics | ozone concentration updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | tin | air_temperature_updated_by_physics | updated air temperature | K | 2 | real | kind_phys | in | F | +!! | po3 | natural_log_of_ozone_forcing_data_pressure_levels | natural log of ozone forcing data pressure levels | log(Pa) | 1 | real | kind_phys | in | F | +!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prdout | ozone_forcing | ozone forcing coefficients | various | 3 | real | kind_phys | in | F | +!! | oz_coeff | number_of_coefficients_in_ozone_forcing_data | number of coefficients in ozone forcing data | index | 0 | integer | | in | F | +!! | delp | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | +!! | ozp1 | cumulative_change_in_ozone_concentration_due_to_production_and_loss_rate | cumulative change in ozone concentration due to production and loss rate | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ozp2 | cumulative_change_in_ozone_concentration_due_to_ozone_mixing_ratio | cumulative change in ozone concentration due to ozone mixing ratio | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ozp3 | cumulative_change_in_ozone_concentration_due_to_temperature | cumulative change in ozone concentration due to temperature | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ozp4 | cumulative_change_in_ozone_concentration_due_to_overhead_ozone_column | cumulative change in ozone concentration due to overhead ozone column | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!> \section genal_ozphys GFS ozphys_run General Algorithm +!> @{ + subroutine ozphys_run ( & + & ix, im, levs, ko3, dt, oz, tin, po3, & + & prsl, prdout, oz_coeff, delp, ldiag3d, & + & ozp1, ozp2, ozp3, ozp4, con_g, me, errmsg, errflg) +! +! this code assumes that both prsl and po3 are from bottom to top +! as are all other variables +! + use machine , only : kind_phys + implicit none +! + ! Interface variables + integer, intent(in) :: im, ix, levs, ko3, oz_coeff, me + real(kind=kind_phys), intent(inout) :: & + & oz(ix,levs) + ! These arrays may not be allocated and need assumed array sizes + real(kind=kind_phys), intent(inout) :: & + & ozp1(:,:), ozp2(:,:), ozp3(:,:), ozp4(:,:) + real(kind=kind_phys), intent(in) :: & + & dt, po3(ko3), prdout(ix,ko3,oz_coeff), & + & prsl(ix,levs), tin(ix,levs), delp(ix,levs), & + & con_g + real :: gravi + logical, intent(in) :: ldiag3d + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! + ! Local variables + integer k,kmax,kmin,l,i,j + logical flg(im) + real(kind=kind_phys) pmax, pmin, tem, temp + real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,oz_coeff), + & ozib(im), colo3(im,levs+1), ozi(ix,levs) +! + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! +! save input oz in ozi + ozi = oz + gravi=1.0/con_g +! +!> - Calculate vertical integrated column ozone values. + if (oz_coeff > 2) then + colo3(:,levs+1) = 0.0 + do l=levs,1,-1 + do i=1,im + colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi + enddo + enddo + endif +! +!> - Apply vertically linear interpolation to the ozone coefficients. + do l=1,levs + pmin = 1.0e10 + pmax = -1.0e10 +! + do i=1,im + wk1(i) = log(prsl(i,l)) + pmin = min(wk1(i), pmin) + pmax = max(wk1(i), pmax) + prod(i,:) = 0.0 + enddo + kmax = 1 + kmin = 1 + do k=1,ko3-1 + if (pmin < po3(k)) kmax = k + if (pmax < po3(k)) kmin = k + enddo +! + do k=kmin,kmax + temp = 1.0 / (po3(k) - po3(k+1)) + do i=1,im + flg(i) = .false. + if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then + flg(i) = .true. + wk2(i) = (wk1(i) - po3(k+1)) * temp + wk3(i) = 1.0 - wk2(i) + endif + enddo + do j=1,oz_coeff + do i=1,im + if (flg(i)) then + prod(i,j) = wk2(i) * prdout(i,k,j) + & + wk3(i) * prdout(i,k+1,j) + endif + enddo + enddo + enddo +! + do j=1,oz_coeff + do i=1,im + if (wk1(i) < po3(ko3)) then + prod(i,j) = prdout(i,ko3,j) + endif + if (wk1(i) >= po3(1)) then + prod(i,j) = prdout(i,1,j) + endif + enddo + enddo + + if (oz_coeff == 2) then + do i=1,im + ozib(i) = ozi(i,l) ! no filling + oz(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) + enddo +! + !if (ldiag3d) then ! ozone change diagnostics + ! do i=1,im + ! ozp1(i,l) = ozp1(i,l) + prod(i,1)*dt + ! ozp2(i,l) = ozp2(i,l) + (oz(i,l) - ozib(i)) + ! enddo + !endif + endif +!> - Calculate the 4 terms of prognostic ozone change during time \a dt: +!! - ozp1(:,:) - Ozone production from production/loss ratio +!! - ozp2(:,:) - Ozone production from ozone mixing ratio +!! - ozp3(:,:) - Ozone production from temperature term at model layers +!! - ozp4(:,:) - Ozone production from column ozone term at model layers + if (oz_coeff == 4) then + do i=1,im + ozib(i) = ozi(i,l) ! no filling + tem = prod(i,1) + prod(i,3)*tin(i,l) + & + prod(i,4)*colo3(i,l+1) +! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) +! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) + oz(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt) + enddo + !if (ldiag3d) then ! ozone change diagnostics + ! do i=1,im + ! ozp1(i,l) = ozp1(i,l) + prod(i,1)*dt + ! ozp2(i,l) = ozp2(i,l) + (oz(i,l) - ozib(i)) + ! ozp3(i,l) = ozp3(i,l) + prod(i,3)*tin(i,l)*dt + ! ozp4(i,l) = ozp4(i,l) + prod(i,4)*colo3(i,l+1)*dt + ! enddo + !endif + endif + + enddo ! vertical loop +! + return + end subroutine ozphys_run +!> @} + + end module ozphys diff --git a/physics/precpd.f b/physics/precpd.f new file mode 100644 index 000000000..9e8f5b696 --- /dev/null +++ b/physics/precpd.f @@ -0,0 +1,735 @@ +!> \file precpd.f +!! This file contains the subroutine that calculates precipitation +!! processes from suspended cloud water/ice. + +!> This module contains the CCPP-compliant zhao_carr_precpd scheme. + module zhaocarr_precpd + contains + +!! \brief Brief description of the subroutine +!! +!! \section arg_table_zhaocarr_precpd_init Argument Table +!! + subroutine zhaocarr_precpd_init () + end subroutine zhaocarr_precpd_init + +!> \defgroup precip GFS precpd Main +!! \brief This subroutine computes the conversion from condensation to +!! precipitation (snow or rain) or evaporation of rain. +!! +!! \section arg_table_zhaocarr_precpd_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|---------------------------------------------------------------|-------------------------------------------------------------------|-------------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | dt | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | del | air_pressure_difference_between_midlayers | pressure level thickness | Pa | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!! | q | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | cwm | cloud_condensed_water_mixing_ratio_updated_by_physics | moist cloud condensed water mixing ratio | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | t | air_temperature_updated_by_physics | layer mean air temperature | K | 2 | real | kind_phys | inout | F | +!! | rn | lwe_thickness_of_explicit_precipitation_amount | explicit precipitation amount on physics timestep | m | 1 | real | kind_phys | out | F | +!! | sr | ratio_of_snowfall_to_rainfall | ratio of snowfall to large-scale rainfall | frac | 1 | real | kind_phys | out | F | +!! | rainp | tendency_of_rain_water_mixing_ratio_due_to_microphysics | tendency of rain water mixing ratio due to microphysics | kg kg-1 s-1 | 2 | real | kind_phys | out | F | +!! | u00k | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | +!! | psautco | coefficient_from_cloud_ice_to_snow | conversion coefficient from cloud ice to snow | none | 1 | real | kind_phys | in | F | +!! | prautco | coefficient_from_cloud_water_to_rain | conversion coefficient from cloud water to rain | none | 1 | real | kind_phys | in | F | +!! | evpco | coefficient_for_evaporation_of_rainfall | coefficient for evaporation of rainfall | none | 0 | real | kind_phys | in | F | +!! | wminco | cloud_condensed_water_conversion_threshold | conversion coefficient from cloud liquid and ice to precipitation | none | 1 | real | kind_phys | in | F | +!! | wk1 | grid_size_related_coefficient_used_in_scale-sensitive_schemes | grid size related coefficient used in scale-sensitive schemes | none | 1 | real | kind_phys | in | F | +!! | lprnt | flag_print | flag for printing diagnostics to output | flag | 0 | logical | | in | F | +!! | jpr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!> \section general_precpd GFS precpd Scheme General Algorithm +!! The following two equations can be used to calculate the +!! precipitation rates of rain and snow at each model level: +!!\f[ +!! P_{r}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{raut}+P_{racw}+P_{sacw}+P_{sm1}+P_{sm2}-E_{rr})d\eta +!! \f] +!! and +!! \f[ +!! P_{s}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{saut}+P_{saci}-P_{sm1}-P_{sm2}-E_{rs})d\eta +!! \f] +!! where \f$p_{s}\f$ and\f$p_{t}\f$ are the surface pressure and the +!! pressure at the top of model domain, respectively, and \f$g\f$ is +!! gravity. The implementation of the precipitation scheme also +!! includes a simplified procedure of computing \f$P_{r}\f$ +!! and \f$P_{s}\f$ (Zhao and Carr (1997) \cite zhao_and_carr_1997). +!! +!! The calculation is as follows: +!! -# Calculate precipitation production by auto conversion and accretion (\f$P_{saut}\f$, \f$P_{saci}\f$, \f$P_{raut}\f$). +!! - The accretion of cloud water by rain, \f$P_{racw}\f$, is not included in the current operational scheme. +!! -# Calculate evaporation of precipitation (\f$E_{rr}\f$ and \f$E_{rs}\f$). +!! -# Calculate melting of snow (\f$P_{sm1}\f$ and \f$P_{sm2}\f$, \f$P_{sacw}\f$). +!! -# Update t and q due to precipitation (snow or rain) production. +!! -# Calculate precipitation at surface (\f$rn\f$) and fraction of frozen precipitation (\f$sr\f$). +!! \section Zhao-Carr_precip_detailed GFS precpd Scheme Detailed Algorithm +!> @{ + subroutine zhaocarr_precpd_run (im,ix,km,dt,del,prsl,q,cwm,t,rn & + &, sr,rainp,u00k,psautco,prautco,evpco,wminco & + &, wk1,lprnt,jpr,errmsg,errflg) + +! +! ****************************************************************** +! * * +! * subroutine for precipitation processes * +! * from suspended cloud water/ice * +! * * +! ****************************************************************** +! * * +! * originally created by q. zhao jan. 1995 * +! * ------- * +! * modified and rewritten by shrinivas moorthi oct. 1998 * +! * ----------------- * +! * and hua-lu pan * +! * ---------- * +! * * +! * references: * +! * * +! * zhao and carr (1997), monthly weather review (august) * +! * sundqvist et al., (1989) monthly weather review. (august) * +! * chuang 2013, modify sr to define frozen precipitation fraction* +! ****************************************************************** +! +! in this code vertical indexing runs from surface to top of the +! model +! +! argument list: +! -------------- +! im : inner dimension over which calculation is made +! ix : maximum inner dimension +! km : number of vertical levels +! dt : time step in seconds +! del(km) : pressure layer thickness (bottom to top) +! prsl(km) : pressure values for model layers (bottom to top) +! q(ix,km) : specific humidity (updated in the code) +! cwm(ix,km) : condensate mixing ratio (updated in the code) +! t(ix,km) : temperature (updated in the code) +! rn(im) : precipitation over one time-step dt (m/dt) +!old sr(im) : index (=-1 snow, =0 rain/snow, =1 rain) +!new sr(im) : "snow ratio", ratio of snow to total precipitation +! cll(ix,km) : cloud cover +!hchuang rn(im) unit in m per time step +! precipitation rate conversion 1 mm/s = 1 kg/m2/s +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, hvap => con_hvap, hfus => con_hfus + &, ttp => con_ttp, cp => con_cp + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! include 'constant.h' +! +! Interface variables + integer, intent(in) :: im, ix, km, jpr + real (kind=kind_phys), intent(in) :: dt + real (kind=kind_phys), intent(in) :: del(ix,km), prsl(ix,km) + real (kind=kind_phys), intent(inout) :: q(ix,km), t(ix,km), & + & cwm(ix,km) + real (kind=kind_phys), intent(out) :: rn(im), sr(im), rainp(im,km) + real (kind=kind_phys), intent(in) :: u00k(im,km) + real (kind=kind_phys), intent(in) :: psautco(2), prautco(2), & + & evpco, wminco(2), wk1(im) + logical, intent(in) :: lprnt + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! Local variables + real (kind=kind_phys) g, h1, h1000 + &, d00 + &, elwv, eliv, row + &, epsq, eliw + &, rcp, rrow + parameter (g=grav, h1=1.e0, h1000=1000.0 + &, d00=0.e0 + &, elwv=hvap, eliv=hvap+hfus, row=1.e3 + &, epsq=2.e-12 + &, eliw=eliv-elwv, rcp=h1/cp, rrow=h1/row) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_p01=0.01 + &, cons_20=20.0 + &, cons_m30=-30.0, cons_50=50.0 +! + real (kind=kind_phys) rnp(im), psautco_l(im), prautco_l(im) & + &, wk2(im) +! + real (kind=kind_phys) err(im), ers(im), precrl(im) & + &, precsl(im), precrl1(im), precsl1(im) & + &, rq(im), condt(im) & + &, conde(im), rconde(im), tmt0(im) & + &, wmin(im,km), wmink(im), pres(im) & + &, wmini(im,km), ccr(im) & + &, tt(im), qq(im), ww(im) & + &, zaodt + real (kind=kind_phys) cclim(km) +! + integer iw(im,km), ipr(im), iwl(im), iwl1(im) +! + logical comput(im) +! + real (kind=kind_phys) ke, rdt, us, climit, cws, csm1 + &, crs1, crs2, cr, aa2, dtcp, c00, cmr + &, tem, c1, c2, wwn +! &, tem, c1, c2, u00b, u00t, wwn + &, precrk, precsk, pres1, qk, qw, qi + &, qint, fiw, wws, cwmk, expf + &, psaut, psaci, amaxcm, tem1, tem2 + &, tmt0k, psm1, psm2, ppr + &, rprs, erk, pps, sid, rid, amaxps + &, praut, fi, qc, amaxrq, rqkll + integer i, k, ihpr, n +! + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +!-------------- GFS psautco/prautco interstitial ---------------- + do i=1, im + wk2(i) = 1.0-wk1(i) + psautco_l(i) = psautco(1)*wk1(i) + psautco(2)*wk2(i) + prautco_l(i) = prautco(1)*wk1(i) + prautco(2)*wk2(i) + enddo +!-----------------------preliminaries --------------------------------- +! +! do k=1,km +! do i=1,im +! cll(i,k) = 0.0 +! enddo +! enddo +! + rdt = h1 / dt +! ke = 2.0e-5 ! commented on 09/10/99 -- opr value +! ke = 2.0e-6 +! ke = 1.0e-5 +!!! ke = 5.0e-5 +!! ke = 7.0e-5 + ke = evpco +! ke = 7.0e-5 + us = h1 + climit = 1.0e-20 + cws = 0.025 +! + zaodt = 800.0 * rdt +! + csm1 = 5.0000e-8 * zaodt + crs1 = 5.00000e-6 * zaodt + crs2 = 6.66600e-10 * zaodt + cr = 5.0e-4 * zaodt + aa2 = 1.25e-3 * zaodt +! + ke = ke * sqrt(rdt) +! ke = ke * sqrt(zaodt) +! + dtcp = dt * rcp +! +! c00 = 1.5e-1 * dt +! c00 = 10.0e-1 * dt +! c00 = 3.0e-1 * dt !05/09/2000 +! c00 = 1.0e-4 * dt !05/09/2000 +! c00 = prautco * dt !05/09/2000 + cmr = 1.0 / 3.0e-4 +! cmr = 1.0 / 5.0e-4 +! c1 = 100.0 + c1 = 300.0 + c2 = 0.5 +! +! +!--------calculate c0 and cmr using lc at previous step----------------- +! + do k=1,km + do i=1,im + tem = (prsl(i,k)*0.00001) +! tem = sqrt(tem) + iw(i,k) = 0.0 +! wmin(i,k) = 1.0e-5 * tem +! wmini(i,k) = 1.0e-5 * tem ! testing for ras +! + + wmin(i,k) = wminco(1) * tem + wmini(i,k) = wminco(2) * tem + + + rainp(i,k) = 0.0 + + enddo + enddo + do i=1,im +! c0(i) = 1.5e-1 +! cmr(i) = 3.0e-4 +! + iwl1(i) = 0 + precrl1(i) = d00 + precsl1(i) = d00 + comput(i) = .false. + rn(i) = d00 + sr(i) = d00 + ccr(i) = d00 +! + rnp(i) = d00 + enddo +!> -# Select columns where rain can be produced, where +!!\f[ +!! cwm > \min (wmin, wmini) +!!\f] +!! where the cloud water and ice conversion threshold: +!! \f[ +!! wmin=wminco(1)\times prsl\times 10^{-5} +!! \f] +!! \f[ +!! wmini=wminco(2)\times prsl\times 10^{-5} +!! \f] + +!------------select columns where rain can be produced-------------- + do k=1, km-1 + do i=1,im + tem = min(wmin(i,k), wmini(i,k)) + if (cwm(i,k) > tem) comput(i) = .true. + enddo + enddo + ihpr = 0 + do i=1,im + if (comput(i)) then + ihpr = ihpr + 1 + ipr(ihpr) = i + endif + enddo +!*********************************************************************** +!-----------------begining of precipitation calculation----------------- +!*********************************************************************** +! do k=km-1,2,-1 + do k=km,1,-1 + do n=1,ihpr + precrl(n) = precrl1(n) + precsl(n) = precsl1(n) + err (n) = d00 + ers (n) = d00 + iwl (n) = 0 +! + i = ipr(n) + tt(n) = t(i,k) + qq(n) = q(i,k) + ww(n) = cwm(i,k) + wmink(n) = wmin(i,k) + pres(n) = prsl(i,k) +! + precrk = max(cons_0, precrl1(n)) + precsk = max(cons_0, precsl1(n)) + wwn = max(ww(n), climit) +! if (wwn .gt. wmink(n) .or. (precrk+precsk) .gt. d00) then + if (wwn > climit .or. (precrk+precsk) > d00) then + comput(n) = .true. + else + comput(n) = .false. + endif + enddo +! +! es(1:ihpr) = fpvs(tt(1:ihpr)) + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + conde(n) = (dt/g) * del(i,k) + condt(n) = conde(n) * rdt + rconde(n) = h1 / conde(n) + qk = max(epsq, qq(n)) + tmt0(n) = tt(n) - 273.16 + wwn = max(ww(n), climit) +! +! pl = pres(n) * 0.01 +! call qsatd(tt(n), pl, qc) +! rq(n) = max(qq(n), epsq) / max(qc, 1.0e-10) +! rq(n) = max(1.0e-10, rq(n)) ! -- relative humidity--- +! +! the global qsat computation is done in pa + pres1 = pres(n) +! qw = es(n) + qw = min(pres1, fpvs(tt(n))) + qw = eps * qw / (pres1 + epsm1 * qw) + qw = max(qw,epsq) +! +! tmt15 = min(tmt0(n), cons_m15) +! ai = 0.008855 +! bi = 1.0 +! if (tmt0(n) .lt. -20.0) then +! ai = 0.007225 +! bi = 0.9674 +! endif +! qi = qw * (bi + ai*min(tmt0(n),cons_0)) +! qint = qw * (1.-0.00032*tmt15*(tmt15+15.)) +! + qi = qw + qint = qw +! if (tmt0(n).le.-40.) qint = qi +! +!-------------------ice-water id number iw------------------------------ +!> -# Calculate ice-water identification number IW (see algorithm in +!! \ref condense). + if(tmt0(n) < -15.) then + fi = qk - u00k(i,k)*qi + if(fi > d00 .or. wwn > climit) then + iwl(n) = 1 + else + iwl(n) = 0 + endif +! endif + elseif (tmt0(n) >= 0.) then + iwl(n) = 0 +! +! if(tmt0(n).lt.0.0.and.tmt0(n).ge.-15.0) then + else + iwl(n) = 0 + if(iwl1(n) == 1 .and. wwn > climit) iwl(n) = 1 + endif +! +! if(tmt0(n).ge.0.) then +! iwl(n) = 0 +! endif +!----------------the satuation specific humidity------------------------ + fiw = float(iwl(n)) + qc = (h1-fiw)*qint + fiw*qi +!----------------the relative humidity---------------------------------- + if(qc <= 1.0e-10) then + rq(n) = d00 + else + rq(n) = qk / qc + endif +!----------------cloud cover ratio ccr---------------------------------- +!> -# Calculate cloud fraction \f$b\f$ (see algorithm in \ref condense) + if(rq(n) < u00k(i,k)) then + ccr(n) = d00 + elseif(rq(n) >= us) then + ccr(n) = us + else + rqkll = min(us,rq(n)) + ccr(n) = h1-sqrt((us-rqkll)/(us-u00k(i,k))) + endif +! + endif + enddo +!-------------------ice-water id number iwl------------------------------ +! do n=1,ihpr +! if (comput(n) .and. (ww(n) .gt. climit)) then +! if (tmt0(n) .lt. -15.0 +! * .or. (tmt0(n) .lt. 0.0 .and. iwl1(n) .eq. 1)) +! * iwl(n) = 1 +! cll(ipr(n),k) = 1.0 ! cloud cover! +! cll(ipr(n),k) = min(1.0, ww(n)*cclim(k)) ! cloud cover! +! endif +! enddo +! +!> -# Precipitation production by auto conversion and accretion +!! - The autoconversion of cloud ice to snow (\f$P_{saut}\f$) is simulated +!! using the equation from Lin et al.(1983)\cite lin_et_al_1983 +!!\f[ +!! P_{saut}=a_{1}(cwm-wmini) +!!\f] +!! Since snow production in this process is caused by the increase in +!! size of cloud ice particles due to depositional growth and +!! aggregation of small ice particles, \f$P_{saut}\f$ is a function of +!! temperature as determined by coefficient \f$a_{1}\f$, given by +!! \f[ +!! a_{1}=psautco \times dt \times exp\left[ 0.025\left(T-273.15\right)\right] +!! \f] +!! +!! - The accretion of cloud ice by snow (\f$P_{saci}\f$) in the +!! regions where cloud ice exists is simulated by +!!\f[ +!! P_{saci}=C_{s}cwm P_{s} +!!\f] +!! where \f$P_{s}\f$ is the precipitation rate of snow. The collection +!! coefficient \f$C_{s}\f$ is a function of temperature since the open +!! structures of ice crystals at relative warm temperatures are more +!! likely to stick, given a collision, than crystals of other shapes +!! (Rogers (1979) \cite rogers_1979). Above the freezing level, +!! \f$C_{s}\f$ is expressed by +!!\f[ +!! C_{s}=c_{1}exp\left[ 0.025\left(T-273.15\right)\right] +!!\f] +!! where \f$c_{1}=1.25\times 10^{-3} m^{2}kg^{-1}s^{-1}\f$ are used. +!! \f$C_{s}\f$ is set to zero below the freezing level. +!! +!--- precipitation production -- auto conversion and accretion +! + do n=1,ihpr + if (comput(n) .and. ccr(n) > 0.0) then + wws = ww(n) + cwmk = max(cons_0, wws) + i = ipr(n) +! amaxcm = max(cons_0, cwmk - wmink(n)) + if (iwl(n) == 1) then ! ice phase + amaxcm = max(cons_0, cwmk - wmini(i,k)) + expf = dt * exp(0.025*tmt0(n)) + psaut = min(cwmk, psautco_l(i)*expf*amaxcm) + ww(n) = ww(n) - psaut + cwmk = max(cons_0, ww(n)) +! cwmk = max(cons_0, ww(n)-wmini(i,k)) + psaci = min(cwmk, aa2*expf*precsl1(n)*cwmk) + + ww(n) = ww(n) - psaci + precsl(n) = precsl(n) + (wws - ww(n)) * condt(n) + else ! liquid water +! +!> - Following Sundqvist et al. (1989)\cite sundqvist_et_al_1989, +!! the autoconversion of cloud water to rain (\f$P_{raut}\f$) can be +!! parameterized from the cloud water mixing ratio \f$m\f$ and cloud +!! coverage \f$b\f$, that is, +!!\f[ +!! P_{raut}=(prautco \times dt )\times (cwm-wmin)\left\{1-exp[-(\frac{cwm-wmin}{m_{r}b})^{2}]\right\} +!!\f] +!! where \f$m_{r}\f$ is \f$3.0\times 10^{-4}\f$. +! for using sundqvist precip formulation of rain +! + amaxcm = max(cons_0, cwmk - wmink(n)) +!! amaxcm = cwmk + tem1 = precsl1(n) + precrl1(n) + tem2 = min(max(cons_0, 268.0-tt(n)), cons_20) + tem = (1.0+c1*sqrt(tem1*rdt)) * (1+c2*sqrt(tem2)) +! + tem2 = amaxcm * cmr * tem / max(ccr(n),cons_p01) + tem2 = min(cons_50, tem2*tem2) +! praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) + praut = (prautco_l(i)*dt) * tem * amaxcm + & * (1.0-exp(-tem2)) + praut = min(praut, cwmk) + ww(n) = ww(n) - praut +! +! - Calculate the accretion of cloud water by rain \f$P_{racw}\f$, +! can be expressed using the cloud mixing ratio \f$cwm\f$ and rainfall +! rate \f$P_{r}\f$: +!\f[ +! P_{racw}=C_{r}cwmP_{r} +!\f] +! where \f$C_{r}=5.0\times10^{-4}m^{2}kg^{-1}s^{-1}\f$ is the +! collection coeffiecient. Note that this process is not included in +! current operational physcics. +! below is for zhao's precip formulation (water) +! +! amaxcm = max(cons_0, cwmk - wmink(n)) +! praut = min(cwmk, c00*amaxcm*amaxcm) +! ww(n) = ww(n) - praut +! +! cwmk = max(cons_0, ww(n)) +! tem1 = precsl1(n) + precrl1(n) +! pracw = min(cwmk, cr*dt*tem1*cwmk) +! ww(n) = ww(n) - pracw +! + precrl(n) = precrl(n) + (wws - ww(n)) * condt(n) +! +!hchuang code change [+1l] : add record to record information in vertical +! turn rnp in unit of ww (cwm and q, kg/kg ???) + rnp(n) = rnp(n) + (wws - ww(n)) + endif + endif + enddo +!> -# Evaporation of precipitation (\f$E_{rr}\f$ and \f$E_{rs}\f$) +!!\n Evaporation of precipitation is an important process that moistens +!! the layers below cloud base. Through this process, some of the +!! precipitating water is evaporated back to the atmosphere and the +!! precipitation efficiency is reduced. +!! - Evaporation of rain is calculated using the equation (Sundqvist(1988)\cite sundqvist_1988): +!!\f[ +!! E_{rr}= evpco \times (u-f)(P_{r})^{\beta} +!!\f] +!! where \f$u\f$ is u00k, \f$f\f$ is the relative humidity. +!! \f$\beta = 0.5\f$ are empirical parameter. +!! - Evaporation of snow is calculated using the equation: +!!\f[ +!! E_{rs}=[C_{rs1}+C_{rs2}(T-273.15)](\frac{u-f}{u})P_{s} +!!\f] +!! where \f$C_{rs1}=5\times 10^{-6}m^{2}kg^{-1}s^{-1}\f$ and +!! \f$C_{rs2}=6.67\times 10^{-10}m^{2}kg^{-1}K^{-1}s^{-1}\f$. The +!! evaporation of melting snow below the freezing level is ignored in +!! this scheme because of the difficulty in the latent heat treatment +!! since the surface of a melting snowflake is usually covered by a +!! thin layer of liquid water. +! +!-----evaporation of precipitation------------------------- +!**** err & ers positive--->evaporation-- negtive--->condensation +! + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + qk = max(epsq, qq(n)) + tmt0k = max(cons_m30, tmt0(n)) + precrk = max(cons_0, precrl(n)) + precsk = max(cons_0, precsl(n)) + amaxrq = max(cons_0, u00k(i,k)-rq(n)) * conde(n) +!---------------------------------------------------------------------- +! increase the evaporation for strong/light prec +!---------------------------------------------------------------------- + ppr = ke * amaxrq * sqrt(precrk) +! ppr = ke * amaxrq * sqrt(precrk*rdt) + if (tmt0(n) .ge. 0.) then + pps = 0. + else + pps = (crs1+crs2*tmt0k) * amaxrq * precsk / u00k(i,k) + end if +!---------------correct if over-evapo./cond. occurs-------------------- + erk=precrk+precsk + if(rq(n).ge.1.0e-10) erk = amaxrq * qk * rdt / rq(n) + if (ppr+pps .gt. abs(erk)) then + rprs = erk / (precrk+precsk) + ppr = precrk * rprs + pps = precsk * rprs + endif + ppr = min(ppr, precrk) + pps = min(pps, precsk) + err(n) = ppr * rconde(n) + ers(n) = pps * rconde(n) + precrl(n) = precrl(n) - ppr +!hchuang code change [+1l] : add record to record information in vertical +! use err for kg/kg/dt not the ppr (mm/dt=kg/m2/dt) +! + rnp(n) = rnp(n) - err(n) +! + precsl(n) = precsl(n) - pps + endif + enddo +!> -# Melting of snow (\f$P_{sm1}\f$ and \f$P_{sm2}\f$) +!!\n In this scheme, we allow snow melting to take place in certain +!! temperature regions below the freezing level in two ways. In both +!! cases, the melted snow is assumed to become raindrops. +!! - One is the continuous melting of snow due to the increase in +!! temperature as it falls down through the freezing level. This +!! process is parameterized as a function of temperature and snow +!! precipitation rate, that is, +!!\f[ +!! P_{sm1}=C_{sm}(T-273.15)^{2}P_{s} +!!\f] +!! where \f$C_{sm}=5\times 10^{-8}m^{2}kg^{-1}K^{-2}s^{-1}\f$ +!! cause the falling snow to melt almost completely before it reaches +!! the \f$T=278.15 K\f$ level. +!! - Another is the immediate melting of melting snow by collection of +!! the cloud water below the freezing level. In order to calculate the +!! melting rate, the collection rate of cloud water by melting snow is +!! computed first. Similar to the collection of cloud water by rain, +!! the collection of cloud water by melting snow can be parameterized +!! to be proportional to the cloud water mixing ratio \f$m\f$ and the +!! precipitation rate of snow \f$P_{s}\f$: +!!\f[ +!! P_{sacw}=C_{r}cwmP_{s} +!!\f] +!! where \f$C_{r}\f$ is the collection coefficient, +!! \f$C_{r}=5.0\times 10^{-4}m^{2}kg^{-1}s^{-1}\f$ . The melting rate +!! of snow then can be computed from +!!\f[ +!! P_{sm2}=C_{ws}P_{sacw} +!!\f] +!! where \f$C_{ws}=0.025\f$. +!--------------------melting of the snow-------------------------------- + do n=1,ihpr + if (comput(n)) then + if (tmt0(n) .gt. 0.) then + amaxps = max(cons_0, precsl(n)) + psm1 = csm1 * tmt0(n) * tmt0(n) * amaxps + psm2 = cws * cr * max(cons_0, ww(n)) * amaxps + ppr = (psm1 + psm2) * conde(n) + if (ppr .gt. amaxps) then + ppr = amaxps + psm1 = amaxps * rconde(n) + endif + precrl(n) = precrl(n) + ppr +! +!hchuang code change [+1l] : add record to record information in vertical +! turn ppr (mm/dt=kg/m2/dt) to kg/kg/dt -> ppr/air density (kg/m3) + rnp(n) = rnp(n) + ppr * rconde(n) +! + precsl(n) = precsl(n) - ppr + else + psm1 = d00 + endif +! +!---------------update t and q------------------------------------------ +!> - Update t and q. +!!\f[ +!! t=t-\frac{L}{C_{p}}(E_{rr}+E_{rs}+P_{sm1})\times dt +!!\f] +!!\f[ +!! q=q+(E_{rr}+E_{rs})\times dt +!!\f] + + tt(n) = tt(n) - dtcp * (elwv*err(n)+eliv*ers(n)+eliw*psm1) + qq(n) = qq(n) + dt * (err(n)+ers(n)) + endif + enddo +! + do n=1,ihpr + iwl1(n) = iwl(n) + precrl1(n) = max(cons_0, precrl(n)) + precsl1(n) = max(cons_0, precsl(n)) + i = ipr(n) + t(i,k) = tt(n) + q(i,k) = qq(n) + cwm(i,k) = ww(n) + iw(i,k) = iwl(n) +!hchuang code change [+1l] : add record to record information in vertical +! rnp = precrl1*rconde(n) unit in kg/kg/dt +! + rainp(i,k) = rnp(n) + enddo +! +! move water from vapor to liquid should the liquid amount be negative +! + do i = 1, im + if (cwm(i,k) < 0.) then + tem = q(i,k) + cwm(i,k) + if (tem >= 0.0) then + q(i,k) = tem + t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) + cwm(i,k) = 0. + elseif (q(i,k) > 0.0) then + cwm(i,k) = tem + t(i,k) = t(i,k) + elwv * rcp * q(i,k) + q(i,k) = 0.0 + endif + endif + enddo +! + enddo ! k loop ends here! +!********************************************************************** +!-----------------------end of precipitation processes----------------- +!********************************************************************** +! +!> -# Calculate precipitation at surface (\f$rn\f$)and determine +!! fraction of frozen precipitation (\f$sr\f$). +!!\f[ +!! rn= (P_{r}(\eta_{sfc})+P_{s}(\eta_{sfc}))/10^3 +!!\f] +!!\f[ +!! sr=\frac{P_{s}(\eta_{sfc})}{P_{s}(\eta_{sfc})+P_{r}(\eta_{sfc})} +!!\f] + do n=1,ihpr + i = ipr(n) + rn(i) = (precrl1(n) + precsl1(n)) * rrow ! precip at surface +! +!----sr=1 if sfc prec is rain ; ----sr=-1 if sfc prec is snow +!----sr=0 for both of them or no sfc prec +! +! rid = 0. +! sid = 0. +! if (precrl1(n) .ge. 1.e-13) rid = 1. +! if (precsl1(n) .ge. 1.e-13) sid = -1. +! sr(i) = rid + sid ! sr=1 --> rain, sr=-1 -->snow, sr=0 -->both +! chuang, june 2013: change sr to define fraction of frozen precipitation instead +! because wpc uses it in their winter experiment + + rid = precrl1(n) + precsl1(n) + if (rid < 1.e-13) then + sr(i) = 0. + else + sr(i) = precsl1(n)/rid + endif + enddo +! + return + end subroutine zhaocarr_precpd_run +!> @} + +!! \section arg_table_zhaocarr_precpd_finalize Argument Table +!! + subroutine zhaocarr_precpd_finalize + end subroutine zhaocarr_precpd_finalize + + + end module zhaocarr_precpd diff --git a/physics/shinhongvdif.F90 b/physics/shinhongvdif.F90 new file mode 100644 index 000000000..c5011218b --- /dev/null +++ b/physics/shinhongvdif.F90 @@ -0,0 +1,2106 @@ +!> \file shinhongvdif.F90 +!! This file contains the CCPP-compliant Shinhong (saYSU) scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Shin and Hong, 2013,2015). +!! +!! Subroutine 'shinhongvdif_run' computes subgrid vertical turbulence mixing +!! using scale-aware YSU K-profile method +!! +!---------------------------------------------------------------------- + + module shinhongvdif + contains + + subroutine shinhongvdif_init () + end subroutine shinhongvdif_init + + subroutine shinhongvdif_finalize () + end subroutine shinhongvdif_finalize + +!> \defgroup SHINHONG FV3GFS shinhongvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! scale-aware Shinhong scheme. +!! +!> \section arg_table_shinhongvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine shinhongvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d, & + u10,v10, & + dx,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! the shinhongpbl (shin and hong 2015) is based on the les study of shin +! and hong (2013). the major ingredients of the shinhongpbl are +! 1) the prescribed nonlocal heat transport profile fit to the les and +! 2) inclusion of explicit scale dependency functions for vertical +! transport in convective pbl. +! so, the shinhongpbl works at the gray zone resolution of convective pbl. +! note that honnert et al. (2011) first suggested explicit scale dependency +! function, and shin and hong (2013) further classified the function by +! stability (u*/w*) in convective pbl and calculated the function for +! nonlocal and local transport separately. +! vertical mixing in the stable boundary layer and free atmosphere follows +! hong (2010) and hong et al. (2006), same as the ysupbl scheme. +! +! shinhongpbl: +! coded and implemented by hyeyum hailey shin (ncar) +! summer 2014 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! references: +! shin and hong (2015) mon. wea. rev. +! shin and hong (2013) j. atmos. sci. +! honnert, masson, and couvreux (2011) j. atmos. sci. +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: 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 :: ckz = 0.001,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 + real(kind=kind_phys),parameter :: karman = 0.4 + real(kind=kind_phys),parameter :: corf=0.000073 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: imvdif = 1 + integer,parameter :: shinhong_tke_diag = 0 +! +! tunable parameters for tke +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c_1 = 1.0,gamcre = 0.224 +! +! tunable parameters for prescribed nonlocal transport profile +! + real(kind=kind_phys),parameter :: mltop = 1.0,sfcfracn1 = 0.075 + real(kind=kind_phys),parameter :: nlfrac = 0.7,enlfrac = -0.4 + real(kind=kind_phys),parameter :: a11 = 1.0,a12 = -1.15 + real(kind=kind_phys),parameter :: ezfac = 1.5 + real(kind=kind_phys),parameter :: cpent = -0.4,rigsmax = 100. + real(kind=kind_phys),parameter :: entfmin = 1.0, entfmax = 5.0 +! 1D in + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt +! 3D in + real(kind=kind_phys), dimension(ix, km) , & + intent(in ) :: phil, & + pi2d, & + p2d, & + ux, & + vx, & + tx + real(kind=kind_phys), dimension( ix, km, ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di, & + phii +! 3D in&out + real(kind=kind_phys), dimension(im, km) , & + intent(inout) :: utnp, & + vtnp, & + ttnp + real(kind=kind_phys), dimension(im, km, ntrac ) , & + intent(inout) :: qtnp +! 2D in + integer, dimension(im) , & + intent(in ) :: landmask + + real(kind=kind_phys), dimension(im) , & + intent(in ) :: heat, & + evap, & + br, & + psim, & + psih, & + psfcpa, & + stress, & + zorl, & + wspd, & + u10, & + v10, & + dx +! 2D: out + integer, dimension(im) , & + intent(out ) :: kpbl1d + + real(kind=kind_phys), dimension(im) , & + intent(out ) :: hpbl, & + dusfc, & + dvsfc, & + dtsfc, & + dqsfc + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! local vars +! + integer :: n,i,k,l,ic + integer :: klpbl + integer :: lmh,lmxl,kts,kte,its,ite +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alpha,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) :: delxy,pu1,pth1,pq1 + real(kind=kind_phys) :: dex,hgame_c + real(kind=kind_phys) :: zfacdx + real(kind=kind_phys) :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 + real(kind=kind_phys) :: mlfrac,ezfrac,sfcfracn + real(kind=kind_phys) :: uwst,uwstx,csfac + 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 +! + integer, dimension(im) :: kpbl + real(kind=kind_phys), dimension(im) :: hol + real(kind=kind_phys), dimension(im) :: deltaoh + real(kind=kind_phys), dimension(im) :: rigs, & + enlfrac2, & + cslen + real(kind=kind_phys), dimension(im) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1, & + ust,hfx,qfx,znt, & + xland + real(kind=kind_phys), dimension(im) :: & + ust3, & + wstar3, & + wstar,delta, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys), dimension(im) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro + real(kind=kind_phys), dimension(im) :: & + efxpbl, & + hpbl_cbl, & + epshol, & + ct +! + real(kind=kind_phys), dimension(im,km) :: & + xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac + real(kind=kind_phys), dimension(im,km) :: & + thx,thvx, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za + real(kind=kind_phys), dimension(im,km) :: & + wscalek + real(kind=kind_phys), dimension(im,km) :: & + xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension(im,km) :: & + mf, & + zfacmf, & + entfacmf + real(kind=kind_phys), dimension(im,km) :: & + q2x, & + hgame2d, & + tflux_e, & + qflux_e, & + tvflux_e + real(kind=kind_phys), dimension( im, km+1 ) :: zq + real(kind=kind_phys), dimension( im, km, ndiff ) :: r3,f3 +! + real(kind=kind_phys), dimension( km ) :: & + uxk,vxk, & + txk,thxk,thvxk, & + q2xk, & + hgame + real(kind=kind_phys), dimension( km ) :: & + ps1d,pb1d,eps1d,pt1d, & + xkze1d,eflx_l1d,eflx_nl1d, & + ptke1 + real(kind=kind_phys), dimension( 2:km ) :: & + s2,gh,rig,el, & + akmk,akhk, & + mfk,ufxpblk,vfxpblk,qfxpblk + real(kind=kind_phys), dimension( km+1 ) :: zqk + + real(kind=kind_phys), dimension(im,km) :: dz8w2d +! + logical, dimension(im) :: pblflg, & + sfcflg, & + stable + logical, dimension( ndiff ) :: ifvmix +! +!------------------------------------------------------------------------------- +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + its = 1 + ite = im + kts = 1 + kte = km + + klpbl = kte + lmh = 1 + lmxl = 1 +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! change xland values + do i=its,ite + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! +! k-start index for cloud and rain +! + ifvmix(:) = .true. +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = its,ite + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + 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) = phii(i,k+1)*conw + za(i,k) = phil(i,k)*conw + enddo + enddo +! + do k = kts,kte + do i = its,ite + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + dz8w2d(i,k)=dzq(i,k) + 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 +! + do i = its,ite + wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9 + enddo + +! write(0,*)"===CALLING shinhong; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"dz8w2d:",dz8w2d(1,1),dz8w2d(1,2),dz8w2d(1,km) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"dx,u10,v10:",dx(1),u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +!---- 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 + enddo +! + do i = its,ite + efxpbl(i) = 0.0 + hpbl_cbl(i) = 0.0 + epshol(i) = 0.0 + ct(i) = 0.0 + enddo +! + do i = its,ite + deltaoh(i) = 0.0 + rigs(i) = 0.0 + enlfrac2(i) = 0.0 + cslen(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + q2x(i,k) = 1.e-4 + enddo + enddo +! + do k = kts,kte + do i = its,ite + hgame2d(i,k) = 0.0 + tflux_e(i,k) = 0.0 + qflux_e(i,k) = 0.0 + tvflux_e(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte + do i = its,ite + mf(i,k) = 0.0 + zfacmf(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) + hpbl_cbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(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 + epshol(i) = hol1 + 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) + 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 +! + 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. + uwst = abs(ust(i)/wstar(i)-0.5) + uwstx = -80.*uwst+14. + csfac = 0.5*(tanh(uwstx)+3.) + cslen(i) = csfac*hpbl(i) + endif + enddo +! +! stable boundary layer +! + do i = its,ite + hpbl_cbl(i) = hpbl(i) + 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 +! +! scale dependency for nonlocal momentum and moisture transport +! + do i = its,ite + pu1=pu(dx(i),cslen(i)) + pq1=pq(dx(i),cslen(i)) + if(pblflg(i)) then + hgamu(i) = hgamu(i)*pu1 + hgamv(i) = hgamv(i)*pu1 + hgamq(i) = hgamq(i)*pq1 + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) - 1 + prpbl(i) = 1.0 + 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) + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1,1)-qx(i,k,1),0.0) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + hfxpbl(i) = we(i)*dthx + pq1=pq(dx(i),cslen(i)) + qfxpbl(i) = we(i)*dqx*pq1 +! + pu1=pu(dx(i),cslen(i)) + 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*pu1,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux*pu1,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx*pu1,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx*pu1,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.) + delb = govrth(i)*dthvx(i) + deltaoh(i) = d1*hpbl(i) + d2*wm2(i)/delb + deltaoh(i) = max(ezfac*deltaoh(i),hpbl(i)-za(i,kpbl(i)-1)-1.) + deltaoh(i) = min(deltaoh(i) ,hpbl(i)) + rigs(i) = govrth(i)*dthvx(i)*deltaoh(i)/(dux**2.+dvx**2.) + rigs(i) = max(min(rigs(i), rigsmax),rimin) + enlfrac2(i) = max(min(wm3/wstar3(i)/(1.+cpent/rigs(i)),entfmax), entfmin) + enlfrac2(i) = enlfrac2(i)*enlfrac + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i))then + entfacmf(i,k) = sqrt(((zq(i,k+1)-hpbl(i))/deltaoh(i))**2.) + endif + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/deltaoh(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 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(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 + 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)) +! in cloud + if(imvdif.eq.1.and.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3 & + .and.(qx(i,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3) then + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alpha = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alpha)*(ri-g*g/ss/tmean/cp*((chi-alpha)/(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 +! +! prescribe nonlocal heat transport below pbl +! + do i = its,ite + deltaoh(i) = deltaoh(i)/hpbl(i) + enddo +! + do i = its,ite + mlfrac = mltop-deltaoh(i) + ezfrac = mltop+deltaoh(i) + zfacmf(i,1) = min(max((zq(i,2)/hpbl(i)),zfmin),1.) + sfcfracn = max(sfcfracn1,zfacmf(i,1)) +! + sflux0 = (a11+a12*sfcfracn)*sflux(i) + snlflux0 = nlfrac*sflux0 + amf1 = snlflux0/sfcfracn + amf2 = -snlflux0/(mlfrac-sfcfracn) + bmf2 = -mlfrac*amf2 + amf3 = snlflux0*enlfrac2(i)/deltaoh(i) + bmf3 = -amf3*mlfrac + hfxpbl(i) = amf3+bmf3 + pth1=pthnl(dx(i),cslen(i)) + hfxpbl(i) = hfxpbl(i)*pth1 +! + do k = kts,klpbl + zfacmf(i,k) = max((zq(i,k+1)/hpbl(i)),zfmin) + if(pblflg(i).and.k.lt.kpbl(i)) then + if(zfacmf(i,k).le.sfcfracn) then + mf(i,k) = amf1*zfacmf(i,k) + else if (zfacmf(i,k).le.mlfrac) then + mf(i,k) = amf2*zfacmf(i,k)+bmf2 + endif + mf(i,k) = mf(i,k)+hfxpbl(i)*exp(-entfacmf(i,k)) + mf(i,k) = mf(i,k)*pth1 + 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.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = 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*(-mf(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 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local heat transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pth1=pthl(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pth1 + al(i,k) = al(i,k)*pth1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + 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) + if(k.eq.kte) then + tflux_e(i,k) = ttend*dz8w2d(i,k) + else + tflux_e(i,k) = tflux_e(i,k+1) + ttend*dz8w2d(i,k) + endif + 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)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = its,ite + f3(i,1,ic) = qx(i,1,ic) + 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 = dt2/del(i,k) + dtodsu = 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,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,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local moisture transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pq1=pq(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pq1 + al(i,k) = al(i,k)*pq1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = kts,kte-1 + do i = its,ite + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! 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,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + if(k.eq.kte) then + qflux_e(i,k) = qtend*dz8w2d(i,k) + else + qflux_e(i,k) = qflux_e(i,k+1) + qtend*dz8w2d(i,k) + endif + tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) + enddo + enddo +! print*,"qtnp:",maxval(qtnp(:,:,1)),minval(qtnp(:,:,1)) +! + do k = kts,kte + do i = its,ite + if(pblflg(i).and.k.lt.kpbl(i)) then + hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) + hgame_c=min(hgame_c,gamcre) + if(k.eq.kte)then + hgame2d(i,k)=hgame_c*0.5*tvflux_e(i,k)*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + else + hgame2d(i,k)=hgame_c*0.5*(tvflux_e(i,k)+tvflux_e(i,k+1))*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + endif + endif + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + if(ifvmix(ic)) then + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + endif + 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 +! + do i = its,ite + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1) + f2(i,1) = vx(i,1) + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = 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 + al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local momentum transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=dx(i)*max(zfacdx,1.0) + pu1=pu(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pu1 + al(i,k) = al(i,k)*pu1 + endif + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + 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 tridi1n(al,ad,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 +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! +!---- calculate sgs tke which is consistent with shinhongpbl algorithm +! + if (shinhong_tke_diag.eq.1) then +! + tke_calculation: do i = its,ite + do k = kts+1,kte + s2(k) = 0.0 + gh(k) = 0.0 + rig(k) = 0.0 + el(k) = 0.0 + akmk(k) = 0.0 + akhk(k) = 0.0 + mfk(k) = 0.0 + ufxpblk(k) = 0.0 + vfxpblk(k) = 0.0 + qfxpblk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = 0.0 + vxk(k) = 0.0 + txk(k) = 0.0 + thxk(k) = 0.0 + thvxk(k) = 0.0 + q2xk(k) = 0.0 + hgame(k) = 0.0 + ps1d(k) = 0.0 + pb1d(k) = 0.0 + eps1d(k) = 0.0 + pt1d(k) = 0.0 + xkze1d(k) = 0.0 + eflx_l1d(k) = 0.0 + eflx_nl1d(k) = 0.0 + ptke1(k) = 1.0 + enddo +! + do k = kts,kte+1 + zqk(k) = 0.0 + enddo +! + do k = kts,kte + uxk(k) = ux(i,k) + vxk(k) = vx(i,k) + txk(k) = tx(i,k) + thxk(k) = thx(i,k) + thvxk(k) = thvx(i,k) + q2xk(k) = q2x(i,k) + hgame(k) = hgame2d(i,k) + enddo +! + do k = kts,kte-1 + if(pblflg(i).and.k.le.kpbl(i)) then + zfacdx = 0.2*hpbl(i)/za(i,k) + delxy = dx(i)*max(zfacdx,1.0) + ptke1(k+1) = ptke(delxy,hpbl(i)) + endif + enddo +! + do k = kts,kte+1 + zqk(k) = zq(i,k) + enddo +! + do k = kts+1,kte + akmk(k) = xkzm(i,k-1) + akhk(k) = xkzh(i,k-1) + mfk(k) = mf(i,k-1)/xkzh(i,k-1) + ufxpblk(k) = ufxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + vfxpblk(k) = vfxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + qfxpblk(k) = qfxpbl(i)*zfacent(i,k-1)/xkzq(i,k-1) + enddo +! + if(pblflg(i)) then + k = kpbl(i) - 1 + dex = 0.25*(q2xk(k+2)-q2xk(k)) + efxpbl(i) = we(i)*dex + endif +! +!---- find the mixing length +! + call mixlen(lmh,uxk,vxk,txk,thxk,qx(i,kts,1),qx(i,kts,ntcw) & + ,q2xk,zqk,ust(i),corf,epshol(i) & + ,s2,gh,rig,el & + ,hpbl(i),kpbl(i),lmxl,ct(i) & + ,hgamu(i),hgamv(i),hgamq(i),pblflg(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1,karman,cp & + ,kts,kte ) +! +!---- solve for the production/dissipation of the turbulent kinetic energy +! + call prodq2(lmh,dt,ust(i),s2,rig,q2xk,el,zqk,akmk,akhk & + ,uxk,vxk,thxk,thvxk & + ,hgamu(i),hgamv(i),hgamq(i),dx(i) & + ,hpbl(i),pblflg(i),kpbl(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1 & + ,kts,kte ) +! +! +!---- carry out the vertical diffusion of turbulent kinetic energy +! + call vdifq(lmh,dt,q2xk,el,zqk & + ,akhk,ptke1 & + ,hgame,hpbl(i),pblflg(i),kpbl(i) & + ,efxpbl(i) & + ,kts,kte ) +! +!---- save the new tke and mixing length. +! + do k = kts,kte + q2x(i,k) = amax1(q2xk(k),epsq2l) + enddo +! + enddo tke_calculation + endif +! +!---- end of tke calculation +! +! +!---- end of vertical diffusion +! + end subroutine shinhongvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + 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, & + 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./cm(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./(cm(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./(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 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 tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + 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 + 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 + 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 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 mixlen(lmh,u,v,t,the,q,cwm,q2,z,ustar,corf,epshol, & + s2,gh,ri,el,hpbl,lpbl,lmxl,ct, & + hgamu,hgamv,hgamq,pblflg, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608,vkarman,cp, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! qnse model constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: blckdr=0.0063,cn=0.75 + real(kind=kind_phys),parameter :: eps1=1.e-12,epsl=0.32,epsru=1.e-7,epsrs=1.e-7 + real(kind=kind_phys),parameter :: el0max=1000.,el0min=1.,elfc=0.23*0.5 + real(kind=kind_phys),parameter :: alph=0.30,beta=1./273.,g=9.81,btg=beta*g + real(kind=kind_phys),parameter :: a1=0.659888514560862645,a2x=0.6574209922667784586 + real(kind=kind_phys),parameter :: b1=11.87799326209552761,b2=7.226971804046074028 + real(kind=kind_phys),parameter :: c1=0.000830955950095854396 + real(kind=kind_phys),parameter :: adnh= 9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: adnm=18.*a1*a1*a2x*(b2-3.*a2x)*btg + real(kind=kind_phys),parameter :: bdnh= 3.*a2x*(7.*a1+b2)*btg,bdnm= 6.*a1*a1 +!------------------------------------------------------------------------------- +! free term in the equilibrium equation for (l/q)**2 +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: aeqh=9.*a1*a2x*a2x*b1*btg*btg & + +9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real(kind=kind_phys),parameter :: aeqm=3.*a1*a2x*b1*(3.*a2x+3.*b2*c1+18.*a1*c1-b2) & + *btg+18.*a1*a1*a2x*(b2-3.*a2x)*btg +!------------------------------------------------------------------------------- +! forbidden turbulence area +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: requ=-aeqh/aeqm + real(kind=kind_phys),parameter :: epsgh=1.e-9,epsgm=requ*epsgh +!------------------------------------------------------------------------------- +! near isotropy for shear turbulence, ww/q2 lower limit +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: ubryl=(18.*requ*a1*a1*a2x*b2*c1*btg & + +9.*a1*a2x*a2x*b2*btg*btg) & + /(requ*adnm+adnh) + real(kind=kind_phys),parameter :: ubry=(1.+epsrs)*ubryl,ubry3=3.*ubry + real(kind=kind_phys),parameter :: aubh=27.*a1*a2x*a2x*b2*btg*btg-adnh*ubry3 + real(kind=kind_phys),parameter :: aubm=54.*a1*a1*a2x*b2*c1*btg -adnm*ubry3 + real(kind=kind_phys),parameter :: bubh=(9.*a1*a2x+3.*a2x*b2)*btg-bdnh*ubry3 + real(kind=kind_phys),parameter :: bubm=18.*a1*a1*c1 -bdnm*ubry3 + real(kind=kind_phys),parameter :: cubr=1.-ubry3,rcubr=1./cubr +!------------------------------------------------------------------------------- +! k profile constants +!------------------------------------------------------------------------------- + real(kind=kind_phys),parameter :: elcbl=0.77 +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,lmxl,lpbl +! + real(kind=kind_phys), intent(in ) :: p608,vkarman,cp + real(kind=kind_phys), intent(in ) :: hpbl,corf,ustar,hgamu,hgamv,hgamq + real(kind=kind_phys), intent(inout) :: ct,epshol +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: cwm, & + q, & + q2, & + t, & + the, & + u, & + v +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(out ) :: el, & + ri, & + gh, & + s2 +! + logical,intent(in) :: pblflg +! +! local vars +! + integer :: k,lpblm + real(kind=kind_phys) :: suk,svk,elocp + real(kind=kind_phys) :: a,aden,b,bden,aubr,bubr,blmx,el0,eloq2x,ghl,s2l, & + qol2st,qol2un,qdzl,rdz,sq,srel,szq,tem,thm,vkrmz,rlambda, & + rlb,rln,f + real(kind=kind_phys) :: ckp + real(kind=kind_phys), dimension( kts:kte ) :: q1, & + en2 + real(kind=kind_phys), dimension( kts+1:kte ) :: dth, & + elm, & + rel +! +!------------------------------------------------------------------------------- +! + elocp=2.72e6/cp + ct=0. +! + do k = kts,kte + q1(k) = 0. + enddo +! + do k = kts+1,kte + dth(k) = the(k)-the(k-1) + enddo +! + do k = kts+2,kte + if(dth(k)>0..and.dth(k-1)<=0.)then + dth(k)=dth(k)+ct + exit + endif + enddo +! +! compute local gradient richardson number +! + do k = kte,kts+1,-1 + rdz=2./(z(k+1)-z(k-1)) + s2l=((u(k)-u(k-1))**2+(v(k)-v(k-1))**2)*rdz*rdz ! s**2 + if(pblflg.and.k.le.lpbl)then + suk=(u(k)-u(k-1))*rdz + svk=(v(k)-v(k-1))*rdz + s2l=(suk-hgamu/hpbl-ufxpbl(k))*suk+(svk-hgamv/hpbl-vfxpbl(k))*svk + endif + s2l=max(s2l,epsgm) + s2(k)=s2l +! + tem=(t(k)+t(k-1))*0.5 + thm=(the(k)+the(k-1))*0.5 + a=thm*p608 + b=(elocp/tem-1.-p608)*thm + ghl=(dth(k)*((q(k)+q(k-1)+cwm(k)+cwm(k-1))*(0.5*p608)+1.) & + +(q(k)-q(k-1)+cwm(k)-cwm(k-1))*a & + +(cwm(k)-cwm(k-1))*b)*rdz ! dtheta/dz + if(pblflg.and.k.le.lpbl)then + ghl=ghl-mf(k)-(hgamq/hpbl+qfxpbl(k))*a + endif + if(abs(ghl)<=epsgh)ghl=epsgh +! + en2(k)=ghl*g/thm ! n**2 + gh(k)=ghl + ri(k)=en2(k)/s2l + enddo +! +! find maximum mixing lengths and the level of the pbl top +! + do k = kte,kts+1,-1 + s2l=s2(k) + ghl=gh(k) + if(ghl>=epsgh)then + if(s2l/ghl<=requ)then + elm(k)=epsl + else + aubr=(aubm*s2l+aubh*ghl)*ghl + bubr= bubm*s2l+bubh*ghl + qol2st=(-0.5*bubr+sqrt(bubr*bubr*0.25-aubr*cubr))*rcubr + eloq2x=1./qol2st + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + else + aden=(adnm*s2l+adnh*ghl)*ghl + bden= bdnm*s2l+bdnh*ghl + qol2un=-0.5*bden+sqrt(bden*bden*0.25-aden) + eloq2x=1./(qol2un+epsru) ! repsr1/qol2un + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + enddo +! + do k = lpbl,lmh,-1 + q1(k)=sqrt(q2(k)) + enddo +! + szq=0. + sq =0. + do k = kte,kts+1,-1 + qdzl=(q1(k)+q1(k-1))*(z(k)-z(k-1)) + szq=(z(k)+z(k-1)-z(lmh)-z(lmh))*qdzl+szq + sq=qdzl+sq + enddo +! +! computation of asymptotic l in blackadar formula +! + el0=min(alph*szq*0.5/sq,el0max) + el0=max(el0 ,el0min) +! +! above the pbl top +! + lpblm=min(lpbl+1,kte) + do k = kte,lpblm,-1 + el(k)=(z(k+1)-z(k-1))*elfc + rel(k)=el(k)/elm(k) + enddo +! +! inside the pbl +! + epshol=min(epshol,0.0) + ckp=elcbl*((1.0-8.0*epshol)**(1./3.)) + if(lpbl>lmh)then + do k = lpbl,lmh+1,-1 + vkrmz=(z(k)-z(lmh))*vkarman + if(pblflg) then + vkrmz=ckp*(z(k)-z(lmh))*vkarman + el(k)=vkrmz/(vkrmz/el0+1.) + else + el(k)=vkrmz/(vkrmz/el0+1.) + endif + rel(k)=el(k)/elm(k) + enddo + endif +! + do k = lpbl-1,lmh+2,-1 + srel=min(((rel(k-1)+rel(k+1))*0.5+rel(k))*0.5,rel(k)) + el(k)=max(srel*elm(k),epsl) + enddo +! +! mixing length for the qnse model in stable case +! + f=max(corf,eps1) + rlambda=f/(blckdr*ustar) + do k = kte,kts+1,-1 + if(en2(k)>=0.0)then ! stable case + vkrmz=(z(k)-z(lmh))*vkarman + rlb=rlambda+1./vkrmz + rln=sqrt(2.*en2(k)/q2(k))/cn + el(k)=1./(rlb+rln) + endif + enddo +! + end subroutine mixlen +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine prodq2(lmh,dtturbl,ustar,s2,ri,q2,el,z,akm,akh, & + uxk,vxk,thxk,thvxk, & + hgamu,hgamv,hgamq,delxy, & + hpbl,pblflg,kpbl, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: epsq2l = 0.01,c0 = 0.55,ceps = 16.6,g = 9.81 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: p608,dtturbl,ustar + real(kind=kind_phys), intent(in ) :: hgamu,hgamv,hgamq,delxy,hpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: uxk, & + vxk, & + thxk, & + thvxk + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: s2, & + ri, & + akm, & + akh, & + el, & + mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: s2l,q2l,deltaz,akml,akhl,en2,pr,bpr,dis,rc02 + real(kind=kind_phys) :: suk,svk,gthvk,govrthvk,pru,prv + real(kind=kind_phys) :: thm,disel +! +!------------------------------------------------------------------------------- +! + rc02=2.0/(c0*c0) +! +! start of production/dissipation loop +! + main_integration: do k = kts+1,kte + deltaz=0.5*(z(k+1)-z(k-1)) + s2l=s2(k) + q2l=q2(k) + suk=(uxk(k)-uxk(k-1))/deltaz + svk=(vxk(k)-vxk(k-1))/deltaz + gthvk=(thvxk(k)-thvxk(k-1))/deltaz + govrthvk=g/(0.5*(thvxk(k)+thvxk(k-1))) + akml=akm(k) + akhl=akh(k) + en2=ri(k)*s2l !n**2 + thm=(thxk(k)+thxk(k-1))*0.5 +! +! turbulence production term +! + if(pblflg.and.k.le.kpbl)then + pru=(akml*(suk-hgamu/hpbl-ufxpbl(k)))*suk + prv=(akml*(svk-hgamv/hpbl-vfxpbl(k)))*svk + else + pru=akml*suk*suk + prv=akml*svk*svk + endif + pr=pru+prv +! +! buoyancy production +! + if(pblflg.and.k.le.kpbl)then + bpr=(akhl*(gthvk-mf(k)-(hgamq/hpbl+qfxpbl(k))*p608*thm))*govrthvk + else + bpr=akhl*gthvk*govrthvk + endif +! +! dissipation +! + disel=min(delxy,ceps*el(k)) + dis=(q2l)**1.5/disel +! + q2l=q2l+2.0*(pr-bpr-dis)*dtturbl + q2(k)=amax1(q2l,epsq2l) +! +! end of production/dissipation loop +! + enddo main_integration +! +! lower boundary condition for q2 +! + q2(kts)=amax1(rc02*ustar*ustar,epsq2l) +! + end subroutine prodq2 +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine vdifq(lmh,dtdif,q2,el,z, & + akhk,ptke1, & + hgame,hpbl,pblflg,kpbl, & + efxpbl, & + kts,kte) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: c_k=1.0,esq=5.0 +! + integer, intent(in ) :: kts,kte + integer, intent(in ) :: lmh,kpbl +! + real(kind=kind_phys), intent(in ) :: dtdif,hpbl,efxpbl +! + logical, intent(in ) :: pblflg +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(in ) :: hgame, & + ptke1 + real(kind=kind_phys), dimension( kts+1:kte ) , & + intent(in ) :: el, & + akhk + real(kind=kind_phys), dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real(kind=kind_phys), dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real(kind=kind_phys) :: aden,akqs,bden,besh,besm,cden,cf,dtozs,ell,eloq2,eloq4 + real(kind=kind_phys) :: elqdz,esh,esm,esqhf,ghl,gml,q1l,rden,rdz + real(kind=kind_phys) :: zak +! + real(kind=kind_phys), dimension( kts+1:kte ) :: zfacentk + real(kind=kind_phys), dimension( kts+2:kte ) :: akq, & + cm, & + cr, & + dtoz, & + rsq2 +! +!------------------------------------------------------------------------------- +! +! vertical turbulent diffusion +! + esqhf=0.5*esq + do k = kts+1,kte + zak=0.5*(z(k)+z(k-1)) !zak of vdifq = za(k-1) of shinhong2d + zfacentk(k)=(zak/hpbl)**3.0 + enddo +! + do k = kte,kts+2,-1 + dtoz(k)=(dtdif+dtdif)/(z(k+1)-z(k-1)) + akq(k)=c_k*(akhk(k)/(z(k+1)-z(k-1))+akhk(k-1)/(z(k)-z(k-2))) + akq(k)=akq(k)*ptke1(k) + cr(k)=-dtoz(k)*akq(k) + enddo +! + akqs=c_k*akhk(kts+1)/(z(kts+2)-z(kts)) + akqs=akqs*ptke1(kts+1) + cm(kte)=dtoz(kte)*akq(kte)+1. + rsq2(kte)=q2(kte) +! + do k = kte-1,kts+2,-1 + cf=-dtoz(k)*akq(k+1)/cm(k+1) + cm(k)=-cr(k+1)*cf+(akq(k+1)+akq(k))*dtoz(k)+1. + rsq2(k)=-rsq2(k+1)*cf+q2(k) + if(pblflg.and.k.lt.kpbl) then + rsq2(k)=rsq2(k)-dtoz(k)*(2.0*hgame(k)/hpbl)*akq(k+1)*(z(k+1)-z(k)) & + +dtoz(k)*(2.0*hgame(k-1)/hpbl)*akq(k)*(z(k)-z(k-1)) + rsq2(k)=rsq2(k)-dtoz(k)*2.0*efxpbl*zfacentk(k+1) & + +dtoz(k)*2.0*efxpbl*zfacentk(k) + endif + enddo +! + dtozs=(dtdif+dtdif)/(z(kts+2)-z(kts)) + cf=-dtozs*akq(lmh+2)/cm(lmh+2) +! + if(pblflg.and.((lmh+1).lt.kpbl)) then + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1) & + -dtozs*(2.0*hgame(lmh+1)/hpbl)*akq(lmh+2)*(z(lmh+2)-z(lmh+1)) & + +dtozs*(2.0*hgame(lmh)/hpbl)*akqs*(z(lmh+1)-z(lmh))) + q2(lmh+1)=q2(lmh+1)-dtozs*2.0*efxpbl*zfacentk(lmh+2) & + +dtozs*2.0*efxpbl*zfacentk(lmh+1) + q2(lmh+1)=q2(lmh+1)/((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + else + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1)) & + /((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + endif +! + do k = lmh+2,kte + q2(k)=(-cr(k)*q2(k-1)+rsq2(k))/cm(k) + enddo +! + end subroutine vdifq +!------------------------------------------------------------------------------- + function pu(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pu + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = 0.070, a3 = 1.0, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + pu=num/den + pu=max(pu,pmin) + pu=min(pu,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pq(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pq + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.0, a2 = -0.098, a3 = 1.0, a4 = 0.106, a5 = 0.5 + real(kind=kind_phys),parameter :: b1 = 2.0 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2 + den=a3*(doh)**b1+a4 + pq=a5*num/den+(1.-a5) + pq=max(pq,pmin) + pq=min(pq,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthnl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthnl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.936, a3 = -1.110, & + a4 = 1.000, a5 = 0.312, a6 = 0.329, a7 = 0.243 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.875 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthnl=a7*num/den+(1.-a7) + pthnl=max(pthnl,pmin) + pthnl=min(pthnl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function pthl(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: pthl + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.870, a3 = -0.913, & + a4 = 1.000, a5 = 0.153, a6 = 0.278, a7 = 0.280 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.5 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2+a3 + den=a4*(doh)**b1+a5*(doh)**b2+a6 + pthl=a7*num/den+(1.-a7) + pthl=max(pthl,pmin) + pthl=min(pthl,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function ptke(d,h) +!------------------------------------------------------------------------------- + use machine , only : kind_phys + implicit none +!------------------------------------------------------------------------------- + real(kind=kind_phys) :: ptke + real(kind=kind_phys),parameter :: pmin = 0.0,pmax = 1.0 + real(kind=kind_phys),parameter :: a1 = 1.000, a2 = 0.070, & + a3 = 1.000, a4 = 0.142, a5 = 0.071 + real(kind=kind_phys),parameter :: b1 = 2.0, b2 = 0.6666667 + real(kind=kind_phys) :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + ptke=num/den + ptke=max(ptke,pmin) + ptke=min(ptke,pmax) +! + return + end function +!------------------------------------------------------------------------------- + end module shinhongvdif diff --git a/physics/ysuvdif.F90 b/physics/ysuvdif.F90 new file mode 100644 index 000000000..e76f2120b --- /dev/null +++ b/physics/ysuvdif.F90 @@ -0,0 +1,1271 @@ +!> \file ysuvdif.F90 +!! This file contains the CCPP-compliant YSU scheme which computes +!! subgrid vertical turbulence mixing using traditional K-profile method +!! Please refer to (Hong, Noh and Dudhia, 2006, MWR). +!! +!! Subroutine 'ysuvdif_run' computes subgrid vertical turbulence mixing +!! using YSU K-profile method +!! +!---------------------------------------------------------------------- + + module ysuvdif + contains + + subroutine ysuvdif_init () + end subroutine ysuvdif_init + + subroutine ysuvdif_finalize () + end subroutine ysuvdif_finalize + +!> \defgroup YSU FV3GFS ysuvdif_run Main +!! \brief This subroutine contains all of the logic for the +!! YSU scheme. +!! +!> \section arg_table_ysuvdif_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | km | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | ux | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | vx | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | +!! | tx | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | +!! | qx | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | +!! | p2d | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | p2di | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | pi2d | dimensionless_exner_function_at_model_layers | Exner function at layers | none | 2 | real | kind_phys | in | F | +!! | vtnp | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | utnp | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | +!! | ttnp | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | +!! | qtnp | tendency_of_tracers_due_to_model_physics | updated tendency of the tracers due to model physics | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | +!! | swh | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step | total sky shortwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | hlw | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step | total sky longwave heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | xmu | zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes | zenith angle temporal adjustment factor for shortwave | none | 1 | real | kind_phys | in | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ndiff | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | psfcpa | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | in | F | +!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | +!! | psim | Monin-Obukhov_similarity_function_for_momentum | Monin-Obukhov similarity function for momentum | none | 1 | real | kind_phys | in | F | +!! | psih | Monin-Obukhov_similarity_function_for_heat | Monin-Obukhov similarity function for heat | none | 1 | real | kind_phys | in | F | +!! | landmask | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | heat | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | +!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | +!! | br | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | ep1 | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | ep2 | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | +!! | xlv | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | +!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | dt | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | +!! | kpbl1d | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | +!! | u10 | x_wind_at_10m | x component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | v10 | y_wind_at_10m | y component of wind at 10 m | m s-1 | 1 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!------------------------------------------------------------------------------- + subroutine ysuvdif_run(ix,im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & + utnp,vtnp,ttnp,qtnp, & + swh,hlw,xmu,ntrac,ndiff,ntcw,ntiw, & + phii,phil,psfcpa, & + zorl,stress,hpbl,psim,psih, & + landmask,heat,evap,wspd,br, & + g,rd,cp,rv,ep1,ep2,xlv, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d,u10,v10,errmsg,errflg ) + + use machine , only : kind_phys +! +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + 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 + real(kind=kind_phys),parameter :: rcl = 1.0 + real(kind=kind_phys),parameter :: karman = 0.4 + integer,parameter :: imvdif = 1 + integer,parameter :: ysu_topdown_pblmix = 1 +! +!------------------------------------------------------------------------------------- +! input variables + integer, intent(in ) :: ix,im,km,ntrac,ndiff,ntcw,ntiw + real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt + + real(kind=kind_phys), dimension( ix,km ), & + intent(in) :: pi2d,p2d,phil,ux,vx,swh,hlw,tx + + real(kind=kind_phys), dimension( ix,km,ntrac ) , & + intent(in ) :: qx + + real(kind=kind_phys), dimension( ix, km+1 ) , & + intent(in ) :: p2di,phii + + real(kind=kind_phys), dimension( im ) , & + intent(in) :: stress,zorl,heat,evap,wspd,br,psim,psih,psfcpa, & + u10,v10,xmu + integer, dimension(im) ,& + intent(in ) :: landmask +! +!---------------------------------------------------------------------------------- +! input/output variables +! + real(kind=kind_phys), dimension( im,km ) , & + intent(inout) :: utnp,vtnp,ttnp + real(kind=kind_phys), dimension( im,km,ntrac ) , & + intent(inout) :: qtnp +! +!--------------------------------------------------------------------------------- +! output variables + integer, dimension( im ), intent(out ) :: kpbl1d + real(kind=kind_phys), dimension( im ), & + intent(out) :: hpbl + + ! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +!-------------------------------------------------------------------------------- +! +! local vars +! + real(kind=kind_phys), dimension( im ) :: hol + real(kind=kind_phys), dimension( im, km+1 ) :: zq +! + real(kind=kind_phys), dimension( im, km ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( im ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + dusfc,dvsfc, & + dtsfc,dqsfc, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( im, km ) :: xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac, & + rhox2, & + hgamt2 +! + real(kind=kind_phys), dimension( im ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( im ) :: xland + real(kind=kind_phys), dimension( im ) :: ust + real(kind=kind_phys), dimension( im ) :: hfx + real(kind=kind_phys), dimension( im ) :: qfx + real(kind=kind_phys), dimension( im ) :: znt + real(kind=kind_phys), dimension( im ) :: uox + real(kind=kind_phys), dimension( im ) :: vox +! + real(kind=kind_phys), dimension( im, km, ndiff) :: r3,f3 + integer, dimension( im ) :: kpbl,kpblold +! + logical, dimension( im ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl, ktrace1, ktrace2, ktrace3 +! +! + 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, rovcp +! + + real(kind=kind_phys), dimension( im, km ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( im ) :: wstar + real(kind=kind_phys), dimension( im ) :: delta + real(kind=kind_phys), dimension( im, km ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( im ) :: 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 +! +!------------------------------------------------------------------------------- +! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + klpbl = km +! + rovcp=rd/cp + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! +! change xland values + do i=1,im + if(landmask(i).eq.0) then !ocean + xland(i) = 2 + else + xland(i) = 1 !land + end if + end do +! + do k = 1,km + do i = 1,im + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qx(i,k,ntcw)/cp-2.834E6*qx(i,k,ntiw)/cp)/pi2d(i,k) + enddo + enddo +! + do k = 1,km + do i = 1,im + tvcon = (1.+ep1*qx(i,k,1)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = 1,im + tvcon = (1.+ep1*qx(i,1,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + hfx(i) = heat(i)*rhox(i)*cp ! reset to the variable in WRF + qfx(i) = evap(i)*rhox(i) ! reset to the variable in WRF + ust(i) = sqrt(stress(i)) ! reset to the variable in WRF + znt(i) = 0.01*zorl(i) ! reset to the variable in WRF + uox(i) = 0.0 + vox(i) = 0.0 + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = 1,im + zq(i,1) = 0. + enddo +! + do k = 1,km + do i = 1,im + zq(i,k+1) = phii(i,k+1)*conw + tvcon = (1.+ep1*qx(i,k,1)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) + enddo + enddo +! + do k = 1,km + do i = 1,im + za(i,k) = phil(i,k)*conw + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + enddo + enddo +! + do i = 1,im + dza(i,1) = za(i,1) + enddo +! + do k = 2,km + do i = 1,im + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo + +! write(0,*)"===CALLING ysu; input:" +! print*,"t:",tx(1,1),tx(1,2),tx(1,km) +! print*,"u:",ux(1,1),ux(1,2),ux(1,km) +! print*,"v:",vx(1,1),vx(1,2),vx(1,km) +! print*,"q:",qx(1,1,1),qx(1,2,1),qx(1,km,1) +! print*,"exner:",pi2d(1,1),pi2d(1,2),pi2d(1,km) +! print*,"phii:",zq(1,1),zq(1,2),zq(1,km+1) +! print*,"phil:",za(1,1),za(1,2),za(1,km) +! print*,"p2d:",p2d(1,1),p2d(1,2),p2d(1,km) +! print*,"p2di:",p2di(1,1),p2di(1,2),p2di(1,km+1) +! print *,"del:",del(1,1),del(1,2),del(1,km) +! print*,"znt,ust,wspd:",znt(1),ust(1),wspd(1) +! print*,"hfx,qfx,xland:",hfx(1),qfx(1),xland(1) +! print*,"rd,rv,g:",rd,rv,g +! print*,"ep1,ep2,xlv:",ep1,ep2,xlv +! print*,"br,psim,psih:",br(1),psim(1),psih(1) +! print*,"u10,v10:",u10(1),v10(1) +! print*,"psfcpa,cp:",psfcpa(1),cp +! print*,"ntrac,ndiff,ntcw,ntiw:",ntrac,ndiff,ntcw,ntiw +! +! +!-----initialize vertical tendencies and +! +! utnp(:,:) = 0. +! vtnp(:,:) = 0. +! ttnp(:,:) = 0. +! qtnp(:,:,:) = 0. +! + do i = 1,im + 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 = 1,im + 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 = 1,klpbl + do i = 1,im + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = 1,klpbl + do i = 1,im + zfac(i,k) = 0.0 + enddo + enddo + do k = 1,klpbl-1 + do i = 1,im + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = 1,im + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = 1,im + 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 = 1,im + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = 1,im + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = 1,im + 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 = 1,im + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), km-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 = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + 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 = 1,im + 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,k,ntcw)+qx(i,k,ntiw)).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,1)+qx(i,k,ntcw))-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,1)+qx(i,k,ntcw))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2,1)+qx(i,k+2,ntcw))) & + - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k,1) +qx(i,k,ntcw))) + 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=swh(i,kk)*xmu(i)+hlw(i,kk) !radiative heating rate 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(qx(i,k+1,1)-qx(i,k,1),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 = 1,klpbl + do i = 1,im + 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 = 1,klpbl + do i = 1,im + 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 = 1,km-1 + do i = 1,im + 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.ntcw.ge.2.and.ntiw.ge.2)then + if((qx(i,k,ntcw)+qx(i,k,ntiw)).gt.0.01e-3.and.(qx(i & + ,k+1,ntcw)+qx(i,k+1,ntiw)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k,1)+qx(i,k+1,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 = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = 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 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,im,km,1) +! +! recover tendencies of heat +! + do k = km,1,-1 + do i = 1,im + 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) + enddo + enddo +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = 1,km + do i = 1,im + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = 1,im + do k = 1,km + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = 1,im + ad(i,1) = 1. + f3(i,1,1) = qx(i,1,1)+qfx(i)*g/del(i,1)*dt2 + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do i = 1,im + f3(i,1,ic) = qx(i,1,ic) + enddo + enddo + endif +! + do k = 1,km-1 + do i = 1,im + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = 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,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,1) + else + f3(i,k+1,1) = qx(i,k+1,1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = 1,km-1 + do i = 1,im + f3(i,k+1,ic) = qx(i,k+1,ic) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = 1,km + do i = 1,im + 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,im,km,ndiff) +! +! recover tendencies of heat and moisture +! + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + qtnp(i,k,1) = qtnp(i,k,1)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,ic)-qx(i,k,ic))*rdt + qtnp(i,k,ic) = qtnp(i,k,ic)+qtend + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = 1,im + do k = 1,km + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = 1,im + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + enddo +! + do k = 1,km-1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = 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 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = 1,km + do i = 1,im + 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 tridi1n(al,ad,cu,r1,r2,au,f1,f2,im,km,1) +! +! recover tendencies of momentum +! + do k = km,1,-1 + do i = 1,im + 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 +! +!---- end of vertical diffusion +! + do i = 1,im + kpbl1d(i) = kpbl(i) + enddo +! +! + end subroutine ysuvdif_run +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do i = 1,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 = 1,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = 2,n-1 + do i = 1,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 = 2,n-1 + do i = 1,l + fk = 1./(cm(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 = 1,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 = 1,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 k = n-1,1,-1 + do i = 1,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,im,km,nt) + use machine , only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: im, km, nt +! + real(kind=kind_phys), dimension( im, 2:km+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( im, km ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( im, km ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( im, km,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = im + n = km +! + do it = 1,nt + do i = 1,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 = 2,n-1 + do i = 1,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 = 1,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,1,-1 + do i = 1,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- +end module ysuvdif +!------------------------------------------------------------------------------- From a4620255a9d694b1f38165dbbb44ba4ea2c58528 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Wed, 19 Jun 2019 15:36:07 -0600 Subject: [PATCH 13/19] scidoc update --- physics/docs/ccppv3_fv3_doxyfile | 441 ++ physics/docs/pdftxt/GFDL_cloud.txt | 23 +- physics/docs/pdftxt/GFS_SAMF.txt | 8 + physics/docs/pdftxt/all_shemes_list.txt | 2 +- physics/gcycle.F90 | 245 + physics/module_sf_mynn.F90 | 2446 +++++++ physics/sfcsub.F | 8745 +++++++++++++++++++++++ 7 files changed, 11902 insertions(+), 8 deletions(-) create mode 100644 physics/docs/ccppv3_fv3_doxyfile create mode 100644 physics/docs/pdftxt/GFS_SAMF.txt create mode 100644 physics/gcycle.F90 create mode 100644 physics/module_sf_mynn.F90 create mode 100644 physics/sfcsub.F diff --git a/physics/docs/ccppv3_fv3_doxyfile b/physics/docs/ccppv3_fv3_doxyfile new file mode 100644 index 000000000..f92aa9b18 --- /dev/null +++ b/physics/docs/ccppv3_fv3_doxyfile @@ -0,0 +1,441 @@ +# Doxyfile 1.8.11 +DOXYFILE_ENCODING = UTF-8 +PROJECT_NAME = "Common Community Physics Package (CCPP) Scientific Documentation" +PROJECT_NUMBER = "Version 3.0" +PROJECT_BRIEF = " " +PROJECT_LOGO = img/dtc_logo.png +OUTPUT_DIRECTORY = doc +CREATE_SUBDIRS = NO +ALLOW_UNICODE_NAMES = NO +OUTPUT_LANGUAGE = English +BRIEF_MEMBER_DESC = YES +REPEAT_BRIEF = NO +ABBREVIATE_BRIEF = +ALWAYS_DETAILED_SEC = NO +INLINE_INHERITED_MEMB = NO +FULL_PATH_NAMES = NO +STRIP_FROM_PATH = +STRIP_FROM_INC_PATH = +SHORT_NAMES = NO +JAVADOC_AUTOBRIEF = NO +QT_AUTOBRIEF = NO +MULTILINE_CPP_IS_BRIEF = NO +INHERIT_DOCS = YES +SEPARATE_MEMBER_PAGES = YES +TAB_SIZE = 4 +ALIASES = +TCL_SUBST = +OPTIMIZE_OUTPUT_FOR_C = NO +OPTIMIZE_OUTPUT_JAVA = NO +OPTIMIZE_FOR_FORTRAN = YES +OPTIMIZE_OUTPUT_VHDL = NO +EXTENSION_MAPPING = .f=FortranFree \ + .F90=FortranFree \ + .f90=FortranFree +MARKDOWN_SUPPORT = YES +AUTOLINK_SUPPORT = YES +BUILTIN_STL_SUPPORT = NO +CPP_CLI_SUPPORT = NO +SIP_SUPPORT = NO +IDL_PROPERTY_SUPPORT = YES +DISTRIBUTE_GROUP_DOC = YES +GROUP_NESTED_COMPOUNDS = NO +SUBGROUPING = YES +INLINE_GROUPED_CLASSES = NO +INLINE_SIMPLE_STRUCTS = NO +TYPEDEF_HIDES_STRUCT = YES +LOOKUP_CACHE_SIZE = 0 +EXTRACT_ALL = YES +EXTRACT_PRIVATE = YES +EXTRACT_PACKAGE = YES +EXTRACT_STATIC = YES +EXTRACT_LOCAL_CLASSES = YES +EXTRACT_LOCAL_METHODS = YES +EXTRACT_ANON_NSPACES = YES +HIDE_UNDOC_MEMBERS = NO +HIDE_UNDOC_CLASSES = NO +HIDE_FRIEND_COMPOUNDS = NO +HIDE_IN_BODY_DOCS = NO +INTERNAL_DOCS = YES + +CASE_SENSE_NAMES = NO + +HIDE_SCOPE_NAMES = NO + +HIDE_COMPOUND_REFERENCE= NO + +SHOW_INCLUDE_FILES = NO + +SHOW_GROUPED_MEMB_INC = NO + +FORCE_LOCAL_INCLUDES = NO + +INLINE_INFO = YES + +SORT_MEMBER_DOCS = NO + +SORT_BRIEF_DOCS = NO +SORT_MEMBERS_CTORS_1ST = NO +SORT_GROUP_NAMES = NO +SORT_BY_SCOPE_NAME = NO +STRICT_PROTO_MATCHING = NO +GENERATE_TODOLIST = YES +GENERATE_TESTLIST = YES +GENERATE_BUGLIST = YES +GENERATE_DEPRECATEDLIST= YES +ENABLED_SECTIONS = YES +MAX_INITIALIZER_LINES = 30 +SHOW_USED_FILES = YES +SHOW_FILES = YES +SHOW_NAMESPACES = YES +FILE_VERSION_FILTER = +LAYOUT_FILE = ccpp_dox_layout.xml +CITE_BIB_FILES = library.bib +QUIET = NO +WARNINGS = YES +WARN_IF_UNDOCUMENTED = NO +WARN_IF_DOC_ERROR = YES +WARN_NO_PARAMDOC = NO +WARN_AS_ERROR = NO +WARN_FORMAT = +WARN_LOGFILE = +INPUT = pdftxt/mainpage.txt \ + pdftxt/all_shemes_list.txt \ + pdftxt/GFSv15_suite.txt \ + pdftxt/GFSv15_suite_TKEEDMF.txt \ + pdftxt/CPT_adv_suite.txt \ + pdftxt/GSD_adv_suite.txt \ + pdftxt/GFS_RRTMG.txt \ + pdftxt/GFS_SFCLYR.txt \ + pdftxt/GFS_NSST.txt \ + pdftxt/GFS_NOAH.txt \ + pdftxt/GFS_SFCSICE.txt \ + pdftxt/GFS_HEDMF.txt \ + pdftxt/GFS_SATMEDMF.txt \ + pdftxt/GFS_GWDPS.txt \ + pdftxt/GFS_OZPHYS.txt \ + pdftxt/GFS_H2OPHYS.txt \ + pdftxt/GFS_RAYLEIGH.txt \ + pgftxt/GFS_SAMF.txt \ + pdftxt/GFS_SAMFdeep.txt \ + pdftxt/GFS_GWDC.txt \ + pdftxt/GFS_SAMFshal.txt \ + pdftxt/GFDL_cloud.txt \ +### pdftxt/GFS_SURFACE_PERT.txt \ + pdftxt/GFS_CALPRECIPTYPE.txt \ +### pdftxt/rad_cld.txt \ + pdftxt/CPT_CSAW.txt \ + pdftxt/CPT_MG3.txt \ + pdftxt/GSD_MYNN_EDMF.txt \ + pdftxt/GSD_CU_GF_deep.txt \ + pdftxt/GSD_RUCLSM.txt \ + pdftxt/GSD_THOMPSON.txt \ +### pdftxt/GFSphys_namelist.txt \ +### pdftxt/GFS_STOCHY_PHYS.txt \ + pdftxt/suite_input.nml.txt \ +### in-core MP + ../gfdl_fv_sat_adj.F90 \ +### time_vary + ../GFS_phys_time_vary.fv3.F90 \ + ../ozne_def.f \ + ../ozinterp.f90 \ + ../h2o_def.f \ + ../h2ointerp.f90 \ + ../aerclm_def.F \ + ../aerinterp.F90 \ + ../iccn_def.F \ + ../iccninterp.F90 \ + ../sfcsub.F \ + ../gcycle.F90 \ + +### Radiation + ../radlw_main.f \ + ../radsw_main.f \ + ../radiation_aerosols.f \ + ../radiation_astronomy.f \ + ../radiation_clouds.f \ + ../radiation_gases.f \ + ../radiation_surface.f \ + ../radlw_param.f \ + ../radlw_datatb.f \ + ../radsw_param.f \ + ../radsw_datatb.f \ + ../dcyc2.f \ +### Land Surface + ../sfc_diff.f \ + ../sfc_nst.f \ + ../module_nst_model.f90 \ + ../module_nst_parameters.f90 \ + ../module_nst_water_prop.f90 \ + ../sfc_drv.f \ + ../sflx.f \ + ../namelist_soilveg.f \ + ../set_soilveg.f \ +### Sea Ice Surface + ../sfc_sice.f \ +### PBL + ../moninedmf.f \ + ../mfpbl.f \ + ../tridi.f \ +### satmedmf + ../satmedmfvdif.F \ + ../mfpblt.f \ + ../mfscu.f \ + ../tridi.f \ +### Orographic Gravity Wave + ../gwdps.f \ +### Rayleigh Dampling + ../rayleigh_damp.f \ +### Prognostic Ozone + ../ozphys_2015.f \ +### ../ozphys.f \ +### stratospheric h2o + ../h2ophys.f \ +### Deep Convection + ../samfdeepcnv.f \ +### Convective Gravity Wave + ../gwdc.f \ +### Shallow Convection + ../samfshalcnv.f \ + ../cnvc90.f \ +### Microphysics +### ../gscond.f \ +### ../precpd.f \ + ../module_bfmicrophysics.f \ +### GFDL cloud MP + ../gfdl_cloud_microphys.F90 \ + ../module_gfdl_cloud_microphys.F90 \ +### + ../GFS_MP_generic.F90 \ + ../calpreciptype.f90 \ +### stochy +### ../GFS_stochastics.F90 \ +### ../surface_perturbation.F90 \ +### ../../stochastic_physics/stochastic_physics.F90 \ +### CPT + ../m_micro.F90 \ +### ../micro_mg2_0.F90 \ + ../micro_mg3_0.F90 \ + ../micro_mg_utils.F90 \ + ../cldmacro.F \ + ../aer_cloud.F \ + ../cldwat2m_micro.F \ + ../wv_saturation.F \ + ../cs_conv_aw_adj.F90 \ + ../cs_conv.F90 \ +### GSD + ../cu_gf_driver.F90 \ + ../cu_gf_deep.F90 \ + ../cu_gf_sh.F90 \ + ../module_MYNNrad_pre.F90 \ + ../module_MYNNrad_post.F90 \ + ../module_MYNNPBL_wrapper.F90 \ + ../module_bl_mynn.F90 \ +### ../module_MYNNSFC_wrapper.F90 \ +### ../module_sf_mynn.F90 \ + ../sfc_drv_ruc.F90 \ + ../module_sf_ruclsm.F90 \ + ../namelist_soilveg_ruc.F90 \ + ../set_soilveg_ruc.F90 \ + ../module_soil_pre.F90 \ + ../mp_thompson_pre.F90 \ + ../module_mp_thompson_make_number_concentrations.F90 \ + ../mp_thompson.F90 \ + ../module_mp_thompson.F90 \ + ../module_mp_radar.F90 \ + ../mp_thompson_post.F90 \ +### utils + ../funcphys.f90 \ + ../physparam.f \ + ../physcons.F90 \ + ../radcons.f90 \ + ../mersenne_twister.f \ + compns_stochy.F90 + + +INPUT_ENCODING = UTF-8 +FILE_PATTERNS = *.f \ + *.F90 \ + *.f90 \ + *.nml \ + *.txt +RECURSIVE = YES +EXCLUDE = +EXCLUDE_SYMLINKS = NO +EXCLUDE_PATTERNS = +EXCLUDE_SYMBOLS = +EXAMPLE_PATH = +EXAMPLE_PATTERNS = +EXAMPLE_RECURSIVE = NO +IMAGE_PATH = img +INPUT_FILTER = +FILTER_PATTERNS = +FILTER_SOURCE_FILES = NO +FILTER_SOURCE_PATTERNS = +USE_MDFILE_AS_MAINPAGE = +SOURCE_BROWSER = NO +INLINE_SOURCES = NO +STRIP_CODE_COMMENTS = YES +REFERENCED_BY_RELATION = YES +REFERENCES_RELATION = YES +REFERENCES_LINK_SOURCE = YES +SOURCE_TOOLTIPS = YES +USE_HTAGS = NO +VERBATIM_HEADERS = YES +#CLANG_ASSISTED_PARSING = NO +#CLANG_OPTIONS = +ALPHABETICAL_INDEX = NO +COLS_IN_ALPHA_INDEX = 5 +IGNORE_PREFIX = +GENERATE_HTML = YES +HTML_OUTPUT = html +HTML_FILE_EXTENSION = .html +HTML_HEADER = +HTML_FOOTER = +HTML_STYLESHEET = +HTML_EXTRA_STYLESHEET = ccpp_dox_extra_style.css +HTML_EXTRA_FILES = +HTML_COLORSTYLE_HUE = 220 +HTML_COLORSTYLE_SAT = 100 +HTML_COLORSTYLE_GAMMA = 80 +HTML_TIMESTAMP = NO +HTML_DYNAMIC_SECTIONS = NO +HTML_INDEX_NUM_ENTRIES = 100 +GENERATE_DOCSET = NO +DOCSET_FEEDNAME = "Doxygen generated docs" +DOCSET_BUNDLE_ID = org.doxygen.Project +DOCSET_PUBLISHER_ID = org.doxygen.Publisher +DOCSET_PUBLISHER_NAME = Publisher +GENERATE_HTMLHELP = NO +CHM_FILE = +HHC_LOCATION = +GENERATE_CHI = NO +CHM_INDEX_ENCODING = +BINARY_TOC = NO +TOC_EXPAND = NO +GENERATE_QHP = NO +QCH_FILE = +QHP_NAMESPACE = org.doxygen.Project +QHP_VIRTUAL_FOLDER = doc +QHP_CUST_FILTER_NAME = +QHP_CUST_FILTER_ATTRS = +QHP_SECT_FILTER_ATTRS = +QHG_LOCATION = +GENERATE_ECLIPSEHELP = NO +ECLIPSE_DOC_ID = org.doxygen.Project +DISABLE_INDEX = YES +GENERATE_TREEVIEW = YES +ENUM_VALUES_PER_LINE = 4 +TREEVIEW_WIDTH = 250 +EXT_LINKS_IN_WINDOW = NO +FORMULA_FONTSIZE = 10 +FORMULA_TRANSPARENT = YES +USE_MATHJAX = YES +MATHJAX_FORMAT = HTML-CSS +MATHJAX_RELPATH = https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.2 +MATHJAX_EXTENSIONS = +MATHJAX_CODEFILE = +SEARCHENGINE = YES +SERVER_BASED_SEARCH = NO +EXTERNAL_SEARCH = NO +SEARCHENGINE_URL = +SEARCHDATA_FILE = searchdata.xml +EXTERNAL_SEARCH_ID = +EXTRA_SEARCH_MAPPINGS = +GENERATE_LATEX = YES +LATEX_OUTPUT = latex +LATEX_CMD_NAME = latex +MAKEINDEX_CMD_NAME = makeindex +COMPACT_LATEX = YES +PAPER_TYPE = a4 +EXTRA_PACKAGES = amsmath +LATEX_HEADER = +LATEX_FOOTER = +LATEX_EXTRA_STYLESHEET = +LATEX_EXTRA_FILES = +PDF_HYPERLINKS = YES +USE_PDFLATEX = YES +LATEX_BATCHMODE = NO +LATEX_HIDE_INDICES = YES +LATEX_SOURCE_CODE = NO + +LATEX_BIB_STYLE = plainnat + +LATEX_TIMESTAMP = NO + +GENERATE_RTF = NO + +RTF_OUTPUT = rtf +COMPACT_RTF = NO +RTF_HYPERLINKS = NO +RTF_STYLESHEET_FILE = +RTF_EXTENSIONS_FILE = +RTF_SOURCE_CODE = NO +GENERATE_MAN = NO +MAN_OUTPUT = man +MAN_EXTENSION = .3 +MAN_SUBDIR = +MAN_LINKS = NO +GENERATE_XML = NO +XML_OUTPUT = xml +XML_PROGRAMLISTING = YES +GENERATE_DOCBOOK = NO +DOCBOOK_OUTPUT = docbook +DOCBOOK_PROGRAMLISTING = NO +GENERATE_AUTOGEN_DEF = NO +GENERATE_PERLMOD = NO +PERLMOD_LATEX = NO +PERLMOD_PRETTY = YES +PERLMOD_MAKEVAR_PREFIX = +ENABLE_PREPROCESSING = NO +MACRO_EXPANSION = NO +EXPAND_ONLY_PREDEF = NO +SEARCH_INCLUDES = YES +INCLUDE_PATH = +INCLUDE_FILE_PATTERNS = +PREDEFINED = CCPP \ + MULTI_GASES \ + 0 +EXPAND_AS_DEFINED = +SKIP_FUNCTION_MACROS = YES +TAGFILES = +GENERATE_TAGFILE = +ALLEXTERNALS = NO +EXTERNAL_GROUPS = YES +EXTERNAL_PAGES = YES +PERL_PATH = /usr/bin/perl +CLASS_DIAGRAMS = YES +MSCGEN_PATH = +DIA_PATH = +HIDE_UNDOC_RELATIONS = NO +HAVE_DOT = YES +DOT_NUM_THREADS = 0 +DOT_FONTNAME = Helvetica +DOT_FONTSIZE = 10 +DOT_FONTPATH = +CLASS_GRAPH = NO +COLLABORATION_GRAPH = NO +GROUP_GRAPHS = YES +UML_LOOK = YES +UML_LIMIT_NUM_FIELDS = 10 +TEMPLATE_RELATIONS = NO +INCLUDE_GRAPH = YES +INCLUDED_BY_GRAPH = NO +CALL_GRAPH = YES +CALLER_GRAPH = NO +GRAPHICAL_HIERARCHY = YES +DIRECTORY_GRAPH = YES +DOT_IMAGE_FORMAT = svg +INTERACTIVE_SVG = NO +DOT_PATH = +DOTFILE_DIRS = +MSCFILE_DIRS = +DIAFILE_DIRS = +PLANTUML_JAR_PATH = +PLANTUML_INCLUDE_PATH = +DOT_GRAPH_MAX_NODES = 200 +MAX_DOT_GRAPH_DEPTH = 0 +DOT_TRANSPARENT = NO +DOT_MULTI_TARGETS = YES +GENERATE_LEGEND = YES +DOT_CLEANUP = YES diff --git a/physics/docs/pdftxt/GFDL_cloud.txt b/physics/docs/pdftxt/GFDL_cloud.txt index 200497f89..6240a259e 100644 --- a/physics/docs/pdftxt/GFDL_cloud.txt +++ b/physics/docs/pdftxt/GFDL_cloud.txt @@ -12,7 +12,8 @@ Physics processes of GFDL cloud MP are described in Figure 1 (also see warm_rain Some unique attributes of GFDL cloud microphysics include: -\section fast_phys Fast Physics in FV3 Dynamical Solver +# Precipitation and Cloud Effects on Dynamics + \image html FV3_structure.png "Figure 1: FV3 structure; Yellow represents external API routines, called once per physics time step; Green are called once per remapping time step; Blue are called once per acoustic time step. " width=10cm The leftmost column of Figure 1 shows the external API calls used during a typical process-split model integration procedure. First, the solver is called, which advances the solver a full "physics" time step. This updated state is then passed to the physical parameterization @@ -27,9 +28,17 @@ done independently within each layer to maintain local (within each layer) stabi This loop is typically performed once per call to the solver, although it is possible to improve the model's stability by executing the loop (and thereby the vertical remapping) multiple times per solver call. -In current fv3gfs, the fast physics (phase-changes only) is called after the "Lagrangian-to-Eulerain" remapping. When \ref fast_sat_adj is activated (do_sat_adj=.true. in \b fv_core_nml block), it adjusts cloud water evaporation (cloud water\f$\rightarrow\f$water vapor), cloud water freezing (cloud water\f$\rightarrow\f$cloud ice), and cloud ice deposition (water vapor\f$\rightarrow\f$cloud ice). The process of condensation is an interesting and well known example. Say dynamics lifts a column of air above saturation, then an adjustment is made to temperature and moisture in order to reach saturation. The tendency of the dynamics has been included in this procedure in order to have the correct balance. -\section gfdl_fast Horizontal Sub-grid Variability ("Scale-aware") +At grid spacing of less than ~10 km, model dynamics should be able to "see" and "feel" the cloud and precipitation condensate; heat content, +heat exchange with the environment, and momentum of condensate should be accounted for. The GFDL microphysics scheme is formulated to +accomplish this through strict moist energy conservation during phase changes, and keeping heat and momentum budgets for all condensate. +This results in thermodynamic consistency between the FV3 microphysics scheme and FV3 dyanmics. + +In current fv3gfs, GFDL in-core fast saturation adjustment (phase-changes only) is called after the "Lagrangian-to-Eulerain" remapping. When \ref fast_sat_adj is activated (do_sat_adj=.true. in \b fv_core_nml block), it adjusts cloud water evaporation (cloud water\f$\rightarrow\f$water vapor), cloud water freezing (cloud water\f$\rightarrow\f$cloud ice), and cloud ice deposition (water vapor\f$\rightarrow\f$cloud ice). The process of condensation is an interesting and well known example. Say dynamics lifts a column of air above saturation, then an adjustment is made to temperature and moisture in order to reach saturation. The tendency of the dynamics has been included in this procedure in order to have the correct balance. + +# Scale-awareness + +Scale-awareness provided by assumed subgrid variability that is directly proportional to grid spacing. Horizontal sub-grid variability is a function of cell area: - Over land: \f[ @@ -46,12 +55,12 @@ relative humidity calculation, evaporation and condensation processes. Scale-aw order FV-type vertical reconstruction (Lin et al. (1994) \cite lin_et_al_1994). \section intro_GFDL_cloud Intraphysics Communication - + For GFDL Cloud MP: \ref arg_table_gfdl_cloud_microphys_run - + For GFDL Fast Physics: \ref arg_table_fv_sat_adj_run + + GFDL Cloud MP: \ref arg_table_gfdl_cloud_microphys_run + + GFDL In-core Fast Saturation Adjustment: \ref arg_table_fv_sat_adj_run \section Gen_GFDL_cloud General Algorithm - + For GFDL Cloud MP: mpdrv() - + For GFDL Fast Physics: fv_sat_adj_work() + + GFDL Cloud MP: mpdrv() + + GFDL In-core Fast Saturation Ajustment: fv_sat_adj_work() */ diff --git a/physics/docs/pdftxt/GFS_SAMF.txt b/physics/docs/pdftxt/GFS_SAMF.txt new file mode 100644 index 000000000..870599652 --- /dev/null +++ b/physics/docs/pdftxt/GFS_SAMF.txt @@ -0,0 +1,8 @@ +/** +\page GFS_SAMF GFS Scale-Aware Simplified Arakawa-Schubert (sa-SAS) Convection Scheme +\section des_samf Description + +\section intra_samf Intraphysics Communication + + +*/ diff --git a/physics/docs/pdftxt/all_shemes_list.txt b/physics/docs/pdftxt/all_shemes_list.txt index 8762cf0d1..702c22256 100644 --- a/physics/docs/pdftxt/all_shemes_list.txt +++ b/physics/docs/pdftxt/all_shemes_list.txt @@ -21,7 +21,7 @@ parameterizations in suites. - \subpage GSD_RUCLSM - \b Cumulus \b Parameterizations - - GFS Scale-Aware Arakawa Schubert (SAS) Scheme + - \subpage GFS_SAMF - \subpage GFS_SAMFdeep - \subpage GFS_SAMFshal - \subpage CSAW_scheme diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 new file mode 100644 index 000000000..411d41004 --- /dev/null +++ b/physics/gcycle.F90 @@ -0,0 +1,245 @@ +!>\file gcycle.F90 +!! This file repopulates specific time-varying surface properties for +!! atmospheric forecast runs. + +!>\ingroup mod_GFS_phys_time_vary +!! This subroutine repopulates specific time-varying surface properties for +!! atmospheric forecast runs. +# 1 "physics/gcycle.F90" + SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) +! +! + USE MACHINE, only: kind_phys + USE PHYSCONS, only: PI => con_PI + USE GFS_typedefs, only: GFS_control_type, GFS_grid_type, & + GFS_sfcprop_type, GFS_cldprop_type + implicit none + + integer, intent(in) :: nblks + type(GFS_control_type), intent(in) :: Model + type(GFS_grid_type), intent(in) :: Grid(nblks) + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) + type(GFS_cldprop_type), intent(inout) :: Cldprop(nblks) + +! +! Local variables +! --------------- + integer :: & + I_INDEX(Model%nx*Model%ny), & + J_INDEX(Model%nx*Model%ny) + + real(kind=kind_phys) :: & + RLA (Model%nx*Model%ny), & + RLO (Model%nx*Model%ny), & + SLMASK (Model%nx*Model%ny), & + OROG (Model%nx*Model%ny), & + OROG_UF (Model%nx*Model%ny), & + SLIFCS (Model%nx*Model%ny), & + TSFFCS (Model%nx*Model%ny), & + SNOFCS (Model%nx*Model%ny), & + ZORFCS (Model%nx*Model%ny), & + TG3FCS (Model%nx*Model%ny), & + CNPFCS (Model%nx*Model%ny), & + AISFCS (Model%nx*Model%ny), & +! F10MFCS(Model%nx*Model%ny), & + VEGFCS (Model%nx*Model%ny), & + VETFCS (Model%nx*Model%ny), & + SOTFCS (Model%nx*Model%ny), & + CVFCS (Model%nx*Model%ny), & + CVBFCS (Model%nx*Model%ny), & + CVTFCS (Model%nx*Model%ny), & + SWDFCS (Model%nx*Model%ny), & + SIHFCS (Model%nx*Model%ny), & + SICFCS (Model%nx*Model%ny), & + SITFCS (Model%nx*Model%ny), & + VMNFCS (Model%nx*Model%ny), & + VMXFCS (Model%nx*Model%ny), & + SLPFCS (Model%nx*Model%ny), & + ABSFCS (Model%nx*Model%ny), & + ALFFC1 (Model%nx*Model%ny*2), & + ALBFC1 (Model%nx*Model%ny*4), & + SMCFC1 (Model%nx*Model%ny*Model%lsoil), & + STCFC1 (Model%nx*Model%ny*Model%lsoil), & + SLCFC1 (Model%nx*Model%ny*Model%lsoil) + + character(len=6) :: tile_num_ch + real(kind=kind_phys), parameter :: pifac=180.0/pi + real(kind=kind_phys) :: sig1t + integer :: npts, len, nb, ix, jx, ls, ios + logical :: exists +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' +! *,lonsinpe(0,1) + + tile_num_ch = " " + if (Model%tile_num < 10) then + write(tile_num_ch, "(a4,i1)") "tile", Model%tile_num + else + write(tile_num_ch, "(a4,i2)") "tile", Model%tile_num + endif + + len = 0 + do jx = Model%jsc, (Model%jsc+Model%ny-1) + do ix = Model%isc, (Model%isc+Model%nx-1) + len = len + 1 + i_index(len) = ix + j_index(len) = jx + enddo + enddo + + sig1t = 0.0 + npts = Model%nx*Model%ny +! + len = 0 + do nb = 1,nblks + do ix = 1,size(Grid(nb)%xlat,1) + len = len + 1 + RLA (len) = Grid(nb)%xlat (ix) * pifac + RLO (len) = Grid(nb)%xlon (ix) * pifac + OROG (len) = Sfcprop(nb)%oro (ix) + OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) + SLIFCS (len) = Sfcprop(nb)%slmsk (ix) + if ( Model%nstf_name(1) > 0 ) then + TSFFCS(len) = Sfcprop(nb)%tref (ix) + else + TSFFCS(len) = Sfcprop(nb)%tsfc (ix) + endif + SNOFCS (len) = Sfcprop(nb)%weasd (ix) + ZORFCS (len) = Sfcprop(nb)%zorl (ix) + TG3FCS (len) = Sfcprop(nb)%tg3 (ix) + CNPFCS (len) = Sfcprop(nb)%canopy (ix) +! F10MFCS (len) = Sfcprop(nb)%f10m (ix) + VEGFCS (len) = Sfcprop(nb)%vfrac (ix) + VETFCS (len) = Sfcprop(nb)%vtype (ix) + SOTFCS (len) = Sfcprop(nb)%stype (ix) + CVFCS (len) = Cldprop(nb)%cv (ix) + CVBFCS (len) = Cldprop(nb)%cvb (ix) + CVTFCS (len) = Cldprop(nb)%cvt (ix) + SWDFCS (len) = Sfcprop(nb)%snowd (ix) + SIHFCS (len) = Sfcprop(nb)%hice (ix) + SICFCS (len) = Sfcprop(nb)%fice (ix) + SITFCS (len) = Sfcprop(nb)%tisfc (ix) + VMNFCS (len) = Sfcprop(nb)%shdmin (ix) + VMXFCS (len) = Sfcprop(nb)%shdmax (ix) + SLPFCS (len) = Sfcprop(nb)%slope (ix) + ABSFCS (len) = Sfcprop(nb)%snoalb (ix) + + ALFFC1 (len ) = Sfcprop(nb)%facsf (ix) + ALFFC1 (len + npts) = Sfcprop(nb)%facwf (ix) + + ALBFC1 (len ) = Sfcprop(nb)%alvsf (ix) + ALBFC1 (len + npts ) = Sfcprop(nb)%alvwf (ix) + ALBFC1 (len + npts*2) = Sfcprop(nb)%alnsf (ix) + ALBFC1 (len + npts*3) = Sfcprop(nb)%alnwf (ix) + + do ls = 1,Model%lsoil + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + enddo + + IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN + SLMASK(len) = 0 + ELSE + SLMASK(len) = 1 + ENDIF + + IF (SLIFCS(len) .EQ. 2) THEN + AISFCS(len) = 1. + ELSE + AISFCS(len) = 0. + ENDIF + +! if (Model%me .eq. 0) +! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) + ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK LOOP------------------------------- + +! check +! call mymaxmin(slifcs,len,len,1,'slifcs') +! call mymaxmin(slmask,len,len,1,'slmsk') +! +#ifndef INTERNAL_FILE_NML + inquire (file=trim(Model%fn_nml),exist=exists) + if (.not. exists) then + write(6,*) 'gcycle:: namelist file: ',trim(Model%fn_nml),' does not exist' + stop + else + open (unit=Model%nlunit, file=trim(Model%fn_nml), action='READ', status='OLD', iostat=ios) + rewind (Model%nlunit) + endif +#endif + CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & + Model%idate(4), Model%idate(2), & + Model%idate(3), Model%idate(1), & + Model%phour, RLA, RLO, SLMASK, & +! Model%fhour, RLA, RLO, SLMASK, & + OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & + SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & + VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, & + SNOFCS, ZORFCS, ALBFC1, TG3FCS, CNPFCS, & + SMCFC1, STCFC1, SLIFCS, AISFCS, & + VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & + CVBFCS, CVTFCS, Model%me, Model%nlunit, & + size(Model%input_nml_file), & + Model%input_nml_file, & + Model%ialb, Model%isot, Model%ivegsrc, & + trim(tile_num_ch), i_index, j_index) +#ifndef INTERNAL_FILE_NML + close (Model%nlunit) +#endif + + len = 0 + do nb = 1,nblks + do ix = 1,size(Grid(nb)%xlat,1) + len = len + 1 + Sfcprop(nb)%slmsk (ix) = SLIFCS (len) + if ( Model%nstf_name(1) > 0 ) then + Sfcprop(nb)%tref(ix) = TSFFCS (len) + else + Sfcprop(nb)%tsfc(ix) = TSFFCS (len) + endif + Sfcprop(nb)%weasd (ix) = SNOFCS (len) + Sfcprop(nb)%zorl (ix) = ZORFCS (len) + Sfcprop(nb)%tg3 (ix) = TG3FCS (len) + Sfcprop(nb)%canopy (ix) = CNPFCS (len) +! Sfcprop(nb)%f10m (ix) = F10MFCS (len) + Sfcprop(nb)%vfrac (ix) = VEGFCS (len) + Sfcprop(nb)%vtype (ix) = VETFCS (len) + Sfcprop(nb)%stype (ix) = SOTFCS (len) + Cldprop(nb)%cv (ix) = CVFCS (len) + Cldprop(nb)%cvb (ix) = CVBFCS (len) + Cldprop(nb)%cvt (ix) = CVTFCS (len) + Sfcprop(nb)%snowd (ix) = SWDFCS (len) + Sfcprop(nb)%hice (ix) = SIHFCS (len) + Sfcprop(nb)%fice (ix) = SICFCS (len) + Sfcprop(nb)%tisfc (ix) = SITFCS (len) + Sfcprop(nb)%shdmin (ix) = VMNFCS (len) + Sfcprop(nb)%shdmax (ix) = VMXFCS (len) + Sfcprop(nb)%slope (ix) = SLPFCS (len) + Sfcprop(nb)%snoalb (ix) = ABSFCS (len) + + Sfcprop(nb)%facsf (ix) = ALFFC1 (len ) + Sfcprop(nb)%facwf (ix) = ALFFC1 (len + npts) + + Sfcprop(nb)%alvsf (ix) = ALBFC1 (len ) + Sfcprop(nb)%alvwf (ix) = ALBFC1 (len + npts ) + Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) + Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) + do ls = 1,Model%lsoil + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + enddo + ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK LOOP------------------------------- + +! check +! call mymaxmin(slifcs,len,len,1,'slifcs') +! +! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour + + RETURN + END diff --git a/physics/module_sf_mynn.F90 b/physics/module_sf_mynn.F90 new file mode 100644 index 000000000..70b98363d --- /dev/null +++ b/physics/module_sf_mynn.F90 @@ -0,0 +1,2446 @@ +!>\file module_sf_mynn.F90 +!! This file contains +!WRF:MODEL_LAYER:PHYSICS +! +!>\ingroup gsd_mynn_sfc +!>\defgroup module_sf_mynn_mod GSD MYNN SFC Module +MODULE module_sf_mynn + +!------------------------------------------------------------------- +!Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES +!for WRFv3.4, v3.4.1, v3.5.1, v3.6, v3.7.1, and v3.9: +! +! BOTH LAND AND WATER: +!1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) +! for first iteration of first time step; afterwards, exact calculation. +!2) Fixed isfflx=0 option to turn off scalar fluxes, but keep momentum +! fluxes for idealized studies (credit: Anna Fitch). +!3) Kinematic viscosity now varies with temperature +!4) Uses Monin-Obukhov flux-profile relationships more consistent with +! those used in the MYNN PBL code. +!5) Allows negative QFX, similar to MYJ scheme +! +! LAND only: +!1) iz0tlnd option is now available with the following options: +! (default) =0: Zilitinkevich (1995) +! =1: Czil_new (modified according to Chen & Zhang 2008) +! =2: Modified Yang et al (2002, 2008) - generalized for all landuse +! =3: constant zt = z0/7.4 (original form; Garratt 1992) +! =4: Pan et al. (1994) with RUC mods for z_q, zili for z_t +!2) Relaxed u* minimum from 0.1 to 0.01 +! +! WATER only: +!1) isftcflx option is now available with the following options: +! (default) =0: z0, zt, and zq from the COARE algorithm. Set COARE_OPT (below) to +! 3.0 (Fairall et al. 2003, default) +! 3.5 (Edson et al 2013) +! =1: z0 from Davis et al (2008), zt & zq from COARE 3.0/3.5 +! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) +! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 +! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 +! +! SNOW/ICE only: +!1) Added Andreas (2002) snow/ice parameterization for thermal and +! moisture roughness to help reduce the cool/moist bias in the arctic +! region. Also added a z0 mod for snow (Andreas et al. 2005, BLM), which +! +! Misc: +! 2) added a more elaborate diagnostic for u10 & V10 for high vertical resolution +! model configurations. +! +! New for v3.9: +! - option for stochastic parameter perturbations (SPP) +! +!NOTE: This code was primarily tested in combination with the RUC LSM. +! Performance with the Noah (or other) LSM is relatively unknown. +!------------------------------------------------------------------- +!For WRF +! USE module_model_constants, only: & +! &g, p1000mb, cp, xlv, ep_2, r_d, r_v, rcp, cpv +! + USE module_bl_mynn, only: tv0, b1, b2, p608, ev, rd, & !, mym_condensation + &esat_blend, xl_blend, qsat_blend + + use physcons, only : cp => con_cp, & + & g => con_g, & + & r_d => con_rd, & + & r_v => con_rv, & + & cpv => con_cvap, & + & cliq => con_cliq, & + & Cice => con_csol, & + & rcp => con_rocp, & + & XLV => con_hvap, & + & XLF => con_hfus, & + & EP_1 => con_fvirt, & + & EP_2 => con_eps + +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!For non-WRF +! REAL , PARAMETER :: g = 9.81 +! REAL , PARAMETER :: r_d = 287. +! REAL , PARAMETER :: cp = 7.*r_d/2. +! REAL , PARAMETER :: r_v = 461.6 +! REAL , PARAMETER :: cpv = 4.*r_v +! REAL , PARAMETER :: rcp = r_d/cp +! REAL , PARAMETER :: XLV = 2.5E6 +! REAL , PARAMETER :: XLF = 3.50E5 + REAL , PARAMETER :: p1000mb = 100000. +! REAL , PARAMETER :: EP_2 = r_d/r_v + + + + REAL, PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2 + REAL, PARAMETER :: wmin=0.1 ! Minimum wind speed + REAL, PARAMETER :: VCONVC=1.25 + REAL, PARAMETER :: SNOWZ0=0.011 + REAL, PARAMETER :: COARE_OPT=3.0 ! 3.0 or 3.5 + !For debugging purposes: + LOGICAL, PARAMETER :: debug_code = .false. + +CONTAINS + +!------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> Fill the PSIM and PSIH tables. The subroutine "sfclayinit". +!! can be found in module_sf_sfclay.F. This subroutine returns +!! the forms from Dyer and Hicks (1974). + SUBROUTINE mynn_sf_init_driver(allowed_to_read) + + LOGICAL, INTENT(in) :: allowed_to_read + +! CALL sfclayinit(allowed_to_read) + + END SUBROUTINE mynn_sf_init_driver + +!------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!! This subroutine + SUBROUTINE SFCLAY_mynn( & + U3D,V3D,T3D,QV3D,P3D,dz8w, & + CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2, & + ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME, & + PSIM,PSIH,PSIX,PSIX10,PSIT,PSIT2, & + XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QSFC,RMOL, & + U10,V10,TH2,T2,Q2,SNOWH, & + GZ1OZ0,WSPD,BR,ISFFLX,DX, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & + KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d, & + tsq,qsq,cov,sh3d,el_pbl,qcg,wstar, & + icloud_bl,qc_bl,cldfra_bl, & + spp_pbl,pattern_spp_pbl, & + 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, & + bl_mynn_cloudpdf) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- T3D 3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- RHO3D 3D density (kg/m3) +!-- dz8w 3D 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) +!-- PSFCPA surface pressure (Pa) +!-- ZNT roughness length (m) +!-- UST u* in similarity theory (m/s) +!-- USTM u* in similarity theory (m/s) w* added to WSPD. This is +! used to couple with TKE scheme but not in MYNN. +! (as of now, USTM = UST in this version) +!-- 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) +!-- RMOL Reciprocal of M-O length (/m) +!-- REGIME flag indicating PBL regime (stable, unstable, etc.) +!-- PSIM similarity stability function for momentum +!-- PSIH similarity 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 qv (specific humidity) at the surface +!-- QSFCMR qv (mixing ratio) at the surface +!-- 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) +!-- SNOWH Snow height (m) +!-- GZ1OZ0 log((z1+ZNT)/ZNT) where ZNT 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 (=0.6112 kPa) +!-- SVP2 constant for saturation vapor pressure (=17.67 dimensionless) +!-- SVP3 constant for saturation vapor pressure (=29.65 K) +!-- SVPT0 constant for saturation vapor pressure (=273.15 K) +!-- EP1 constant for virtual temperature (Rv/Rd - 1) (dimensionless) +!-- EP2 constant for spec. hum. calc (Rd/Rv = 0.622) (dimensionless) +!-- EP3 constant for spec. hum. calc (1 - Rd/Rv = 0.378 ) (dimensionless) +!-- KARMAN Von Karman constant +!-- 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: z0, zt, and zq from COARE3.0/3.5 (Fairall et al 2003/Edson et al 2013) +! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5 +! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) +! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 +! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 +!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.10, +! (land =1: Czil_new (modified according to Chen & Zhang 2008) +! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse +! =3: constant zt = z0/7.4 (Garratt 1992) +! =4: Pan et al (1994) for zq; ZIlitintevich for zt +!-- bl_mynn_cloudpdf =0: Mellor & Yamada +! =1: Kuwano et al. +!-- el_pbl = mixing length from PBL scheme (meters) +!-- Sh3d = Stability finction for heat (unitless) +!-- cov = T'q' from PBL scheme +!-- tsq = T'T' from PBL scheme +!-- qsq = q'q' from PBL scheme +!-- icloud_bl = namelist option for subgrid scale cloud/radiation feedback +!-- qc_bl = subgrid scale (bloundary layer) clouds +!-- cldfra_bl = subgridscale cloud fraction +! +!-- 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 +!================================================================= +! SCALARS +!=================================== + 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) :: SVP1,SVP2,SVP3,SVPT0 + REAL, INTENT(IN) :: EP1,EP2,KARMAN + REAL, INTENT(IN) :: CP,G,ROVCP,R,XLV !,DX +!NAMELIST OPTIONS: + INTEGER, INTENT(IN) :: ISFFLX + INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND,& + bl_mynn_cloudpdf,& + icloud_bl + INTEGER, INTENT(IN),OPTIONAL :: spp_pbl + +!=================================== +! 3D VARIABLES +!=================================== + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + QV3D, & + P3D, & + T3D, & + QC3D, & + U3D,V3D, & + RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_bl, & + cldfra_bl + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl +!=================================== +! 2D VARIABLES +!=================================== + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: MAVAIL, & + PBLH, & + XLAND, & + TSK, & + QCG, & + PSFCPA, & + SNOWH, & + DX + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT ) :: U10,V10, & + TH2,T2,Q2 + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: ck,cka,cd,cda,ustm +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: REGIME, & + HFX, & + QFX, & + LH, & + MOL,RMOL, & + QSFC, & + ZNT, & + ZOL, & + UST, & + CHS2, & + CQS2, & + CHS, & + CH, & + FLHC,FLQC, & + GZ1OZ0,WSPD,BR, & + PSIM,PSIH, & + WSTAR, & + PSIX,PSIX10,PSIT,PSIT2 + +!ADDITIONAL OUTPUT +!JOE-begin + REAL, DIMENSION( ims:ime, jms:jme ) :: z0zt_ratio, & + BulkRi,qstar,resist,logres +!JOE-end +!=================================== +! 1D LOCAL ARRAYS +!=================================== + REAL, DIMENSION( its:ite ) :: U1D, & + V1D, & + U1D2,V1D2, & !level2 winds + QV1D, & + P1D, & + T1D,QC1D, & + RHO1D, & + dz8w1d, & !level 1 height + dz2w1d !level 2 height + + REAL, DIMENSION( its:ite ) :: rstoch1D + + ! VARIABLE FOR PASSING TO MYM_CONDENSATION + REAL, DIMENSION(kts:kts+1 ) :: dummy1,dummy2,dummy3,dummy4, & + dummy5,dummy6,dummy7,dummy8, & + dummy9,dummy10,dummy11, & + dummy12,dummy13,dummy14 + + REAL, DIMENSION( its:ite ) :: vt1,vq1 + REAL, DIMENSION(kts:kts+1) :: thl, qw, vt, vq + REAL :: ql + + INTEGER :: I,J,K,itf,jtf,ktf +!----------------------------------------------------------- +!joe -test printing of constants: +! print*,"cp=", cp +! print*,"g=", g +! print*,"Rd=", r_d +! print*,"Rv=", r_v +! print*,"cpc=", cpv +! print*,"cliq=", cliq +! print*,"cice=", Cice +! print*,"rcp=", rcp +! print*,"xlv=", XLV +! print*,"xlf=", XLF +! print*,"ep1=", EP_1 +! print*,"ep2=", EP_2 + + + itf=ite !MIN0(ite,ide-1) + jtf=jte !MIN0(jte,jde-1) + ktf=kte !MIN0(kte,kde-1) + + DO J=jts,jte + DO i=its,ite + dz8w1d(I) = dz8w(i,kts,j) + dz2w1d(I) = dz8w(i,kts+1,j) + U1D(i) =U3D(i,kts,j) + V1D(i) =V3D(i,kts,j) + !2nd model level winds - for diags with high-res grids + U1D2(i) =U3D(i,kts+1,j) + V1D2(i) =V3D(i,kts+1,j) + QV1D(i)=QV3D(i,kts,j) + QC1D(i)=QC3D(i,kts,j) + P1D(i) =P3D(i,kts,j) + T1D(i) =T3D(i,kts,j) + RHO1D(i)=RHO3D(i,kts,j) + if (spp_pbl==1) then + rstoch1D(i)=pattern_spp_pbl(i,kts,j) + else + rstoch1D(i)=0.0 + endif + ENDDO + + IF (itimestep==1) THEN + DO i=its,ite + vt1(i)=0. + vq1(i)=0. + UST(i,j)=MAX(0.025*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001) + MOL(i,j)=0. ! Tstar + QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j)) + qstar(i,j)=0.0 + ENDDO + ELSE + DO i=its,ite + DO k = kts,kts+1 + ql = qc3d(i,k,j)/(1.+qc3d(i,k,j)) + qw(k) = qv3d(i,k,j)/(1.+qv3d(i,k,j)) + ql + thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j) + dummy1(k)=dz8w(i,k,j) + dummy2(k)=thl(k) + dummy3(k)=qw(k) + dummy4(k)=p3d(i,k,j) + dummy5(k)=pi3d(i,k,j) + dummy6(k)=tsq(i,k,j) + dummy7(k)=qsq(i,k,j) + dummy8(k)=cov(i,k,j) + dummy9(k)=Sh3d(i,k,j) + dummy10(k)=el_pbl(i,k,j) + dummy14(k)=th3d(i,k,j) + if(icloud_bl > 0) then + dummy11(k)=qc_bl(i,k,j) + dummy12(k)=cldfra_bl(i,k,j) + else + dummy11(k)=0.0 + dummy12(k)=0.0 + endif + dummy13(k)=0.0 !sgm + ENDDO + + ! NOTE: The last grid number is kts+1 instead of kte. + CALL mym_condensation (kts,kts+1, dx(i,j),& + & dummy1,dummy2,dummy3, & + & dummy4,dummy5,dummy6, & + & dummy7,dummy8,dummy9, & + & dummy10,bl_mynn_cloudpdf,& + & dummy11,dummy12, & + & PBLH(i,j),HFX(i,j), & + & vt(kts:kts+1), vq(kts:kts+1), & + & dummy14,dummy13) + +! ! NOTE: The last grid number is kts+1 instead of kte. +! CALL mym_condensation (kts,kts+1, dx, & +! & dz8w(i,kts:kts+1,j), & +! & thl(kts:kts+1), & +! & qw(kts:kts+1), & +! & p3d(i,kts:kts+1,j), & +! & pi3d(i,kts:kts+1,j), & +! & tsq(i,kts:kts+1,j), & +! & qsq(i,kts:kts+1,j), & +! & cov(i,kts:kts+1,j), & +! & Sh3d(i,kts:kts+1,j), & !JOE - cloud PDF testing +! & el_pbl(i,kts:kts+1,j), & !JOE - cloud PDF testing +! & bl_mynn_cloudpdf, & !JOE - cloud PDF testing +! & qc_bl2D(i,kts:kts+1), & !JOE-subgrid BL clouds +! & cldfra_bl2D(i,kts:kts+1),& !JOE-subgrid BL clouds +! & PBLH(i,j),HFX(i,j), & !JOE-subgrid BL clouds +! & vt(kts:kts+1), vq(kts:kts+1), & + ! & th,sgm) + vt1(i) = vt(kts) + vq1(i) = vq(kts) + ENDDO + ENDIF + + CALL SFCLAY1D_mynn( & + J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & + U1D2,V1D2,dz2w1d, & + CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),& + CQS2(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), & + PSIX(ims,j),PSIX10(ims,j),PSIT(ims,j),PSIT2(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),SNOWH(ims,j), & + QSFC(ims,j),LH(ims,j), & + GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX(ims,j),& + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + ch(ims,j),vt1,vq1,qc1d,qcg(ims,j), & + itimestep, & +!JOE-begin additional output + z0zt_ratio(ims,j),wstar(ims,j), & + qstar(ims,j),resist(ims,j),logres(ims,j), & +!JOE-end + spp_pbl,rstoch1D, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte & + ,isftcflx,iz0tlnd, & + USTM(ims,j),CK(ims,j),CKA(ims,j), & + CD(ims,j),CDA(ims,j) & + ) + + ENDDO + + END SUBROUTINE SFCLAY_MYNN + +!------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!! This subroutine calculates + SUBROUTINE SFCLAY1D_mynn( & + J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & + U1D2,V1D2,dz2w1d, & + CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2, & + PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME, & + PSIM,PSIH,PSIX,PSIX10,PSIT,PSIT2, & + XLAND,HFX,QFX,TSK, & + U10,V10,TH2,T2,Q2,FLHC,FLQC,SNOWH, & + QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & + KARMAN,ch,vt1,vq1,qc1d,qcg, & + itimestep, & +!JOE-additional output + zratio,wstar,qstar,resist,logres, & +!JOE-end + spp_pbl,rstoch1D, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte & + ,isftcflx, iz0tlnd, & + ustm,ck,cka,cd,cda & + ) + +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! SCALARS +!----------------------------- + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + J, itimestep + + REAL, PARAMETER :: XKA=2.4E-5 !molecular diffusivity + REAL, PARAMETER :: PRT=1. !prandlt number + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2 + REAL, INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV !,DX + +!----------------------------- +! NAMELIST OPTIONS +!----------------------------- + INTEGER, INTENT(IN) :: ISFFLX + INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND + INTEGER, INTENT(IN) :: spp_pbl + +!----------------------------- +! 1D ARRAYS +!----------------------------- + REAL, DIMENSION( ims:ime ), INTENT(IN) :: MAVAIL, & + PBLH, & + XLAND, & + TSK, & + PSFCPA, & + QCG, & + SNOWH, DX + + REAL, DIMENSION( its:ite ), INTENT(IN) :: U1D,V1D, & + U1D2,V1D2, & + QV1D,P1D, & + T1D,QC1d, & + dz8w1d,dz2w1d, & + RHO1D, & + vt1,vq1 + + REAL, DIMENSION( ims:ime ), INTENT(INOUT) :: REGIME, & + HFX,QFX,LH, & + MOL,RMOL, & + QSFC, & + ZNT, & + ZOL, & + UST, & + CHS2,CQS2, & + CHS,CH, & + FLHC,FLQC, & + GZ1OZ0, & + WSPD, & + BR, & + PSIM,PSIH, & + PSIX,PSIX10,PSIT,PSIT2 + + REAL, DIMENSION( its:ite ), INTENT(IN) :: rstoch1D + + ! DIAGNOSTIC OUTPUT + REAL, DIMENSION( ims:ime ), INTENT(OUT) :: U10,V10, & + TH2,T2,Q2 + + REAL, OPTIONAL, DIMENSION( ims:ime ) , & + INTENT(OUT) :: ck,cka,cd,cda,ustm +!-------------------------------------------- +!JOE-additinal output + REAL, DIMENSION( ims:ime ) :: zratio,wstar,qstar, & + resist,logres +!JOE-end +!---------------------------------------------------------------- +! LOCAL VARS +!---------------------------------------------------------------- + REAL :: thl1,sqv1,sqc1,exner1,sqvg,sqcg,vv,ww + + REAL, DIMENSION(its:ite) :: & + ZA, & !Height of lowest 1/2 sigma level(m) + ZA2, & !Height of 2nd lowest 1/2 sigma level(m) + THV1D, & !Theta-v at lowest 1/2 sigma (K) + TH1D, & !Theta at lowest 1/2 sigma (K) + TC1D, & !T at lowest 1/2 sigma (Celsius) + TV1D, & !Tv at lowest 1/2 sigma (K) + QVSH, & !qv at lowest 1/2 sigma (spec humidity) + PSIH2,PSIM2, & !M-O stability functions at z=2 m + PSIH10,PSIM10, & !M-O stability functions at z=10 m + WSPDI, & + CPM, & + z_t,z_q, & !thermal & moisture roughness lengths + ZNTstoch, & + GOVRTH, & !g/theta + THGB, & !theta at ground + THVGB, & !theta-v at ground + PSFC, & !press at surface (Pa/1000) + QSFCMR, & !qv at surface (mixing ratio, kg/kg) + GZ2OZ0, & !LOG((2.0+ZNT(I))/ZNT(I)) + GZ10OZ0, & !LOG((10.+ZNT(I))/ZNT(I)) + GZ2OZt, & !LOG((2.0+z_t(i))/z_t(i)) + GZ10OZt, & !LOG((10.+z_t(i))/z_t(i)) + GZ1OZt !LOG((ZA(I)+z_t(i))/z_t(i)) + + INTEGER :: N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER, yesno + INTEGER, PARAMETER :: ITMAX=1 + + REAL :: PL,THCON,TVCON,E1 + REAL :: DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 + REAL :: DTG,DTTHX,DTHDZ,PSIT10,PSIQ,PSIQ2,PSIQ10 + REAL :: FLUXC,VSGD + REAL :: restar,VISC,DQG,OLDUST,OLDTST + REAL, PARAMETER :: psilim = -10. ! ONLY AFFECTS z/L > 2.0 +!------------------------------------------------------------------- + + DO I=its,ite + ! CONVERT GROUND & LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE: + ! PSFC cmb + PSFC(I)=PSFCPA(I)/1000. + THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP !(K) + ! PL cmb + PL=P1D(I)/1000. + THCON=(100./PL)**ROVCP + TH1D(I)=T1D(I)*THCON !(Theta, K) + TC1D(I)=T1D(I)-273.15 !(T, Celsius) + + ! CONVERT TO VIRTUAL TEMPERATURE + QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) + TVCON=(1.+EP1*QVSH(I)) + THV1D(I)=TH1D(I)*TVCON !(K) + TV1D(I)=T1D(I)*TVCON !(K) + + !RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver + ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level + ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level + GOVRTH(I)=G/TH1D(I) + ENDDO + + DO I=its,ite + IF (TSK(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TSK(I)) - & + & 11.64*LOG(273.15/TSK(I)) + 0.02265*(273.15 - TSK(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(TSK(I)-SVPT0)/(TSK(I)-SVP3)) + ENDIF + !FOR LAND POINTS, QSFC can come from LSM, ONLY RECOMPUTE OVER WATER + IF (xland(i).gt.1.5 .or. QSFC(i).le.0.0) THEN !WATER + QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1) !specific humidity + QSFCMR(I)=EP2*E1/(PSFC(I)-E1) !mixing ratio + ELSE !LAND + QSFCMR(I)=QSFC(I)/(1.-QSFC(I)) + ENDIF + + IF (TSK(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE + E1=SVP1*EXP(4648*(1./273.15 - 1./T1D(I)) - & + & 11.64*LOG(273.15/T1D(I)) + 0.02265*(273.15 - T1D(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3)) + ENDIF + PL=P1D(I)/1000. + CPM(I)=CP*(1.+0.84*QV1D(I)) + ENDDO + + DO I=its,ite + WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)) + + !account for partial condensation + exner1=(p1d(I)/p1000mb)**ROVCP + sqc1=qc1d(I)/(1.+qc1d(I)) !lowest mod level cloud water spec hum + sqv1=QVSH(I) !lowest mod level water vapor spec hum + thl1=TH1D(I)-xlvcp/exner1*sqc1 + sqvg=qsfc(I) !sfc water vapor spec hum + sqcg=qcg(I)/(1.+qcg(I)) !sfc cloud water spec hum + + vv = thl1-THGB(I) + !TGS:ww = mavail(I)*(sqv1-sqvg) + (sqc1-sqcg) + ww = (sqv1-sqvg) + (sqc1-sqcg) + + !TGS:THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) + THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)) + + DTHDZ=(TH1D(I)-THGB(I)) + DTHVDZ=(THV1D(I)-THVGB(I)) + !DTHVDZ= (vt1(i) + 1.0)*vv + (vq1(i) + tv0)*ww + + !-------------------------------------------------------- + ! Calculate the convective velocity scale (WSTAR) and + ! subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) + ! and Mahrt and Sun (1995, MWR), respectively + !------------------------------------------------------- + ! Use Beljaars over land and water + fluxc = max(hfx(i)/RHO1D(i)/cp & + & + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.) + WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**.33 + + !-------------------------------------------------------- + ! Mahrt and Sun low-res correction + ! (for 13 km ~ 0.37 m/s; for 3 km == 0 m/s) + !-------------------------------------------------------- + VSGD = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 + WSPD(I)=SQRT(WSPD(I)*WSPD(I)+WSTAR(I)*WSTAR(I)+vsgd*vsgd) + WSPD(I)=MAX(WSPD(I),wmin) + + !-------------------------------------------------------- + ! CALCULATE THE BULK RICHARDSON NUMBER OF SURFACE LAYER, + ! ACCORDING TO AKB(1976), EQ(12). + !-------------------------------------------------------- + BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) + !SET LIMITS ACCORDING TO Li et al. (2010) Boundary-Layer Meteorol (p.158) + BR(I)=MAX(BR(I),-20.0) + BR(I)=MIN(BR(I),2.0) + + ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) + !if (itimestep .GT. 1) THEN + ! IF(MOL(I).LT.0.)BR(I)=MIN(BR(I),0.0) + !ENDIF + + !IF(I .eq. 2)THEN + ! write(*,1006)"BR:",BR(I)," fluxc:",fluxc," vt1:",vt1(i)," vq1:",vq1(i) + ! write(*,1007)"XLAND:",XLAND(I)," WSPD:",WSPD(I)," DTHVDZ:",DTHVDZ," WSTAR:",WSTAR(I) + !ENDIF + + ENDDO + + 1006 format(A,F7.3,A,f9.4,A,f9.5,A,f9.4) + 1007 format(A,F2.0,A,f6.2,A,f7.3,A,f7.2) + +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- +!--- BEGIN ITERATION LOOP (ITMAX=5); USUALLY CONVERGES IN TWO PASSES +!-------------------------------------------------------------------- +!-------------------------------------------------------------------- + + DO I=its,ite + + ITER = 1 + DO WHILE (ITER .LE. ITMAX) + + !COMPUTE KINEMATIC VISCOSITY (m2/s) Andreas (1989) CRREL Rep. 89-11 + !valid between -173 and 277 degrees C. + VISC=1.326e-5*(1. + 6.542e-3*TC1D(I) + 8.301e-6*TC1D(I)*TC1D(I) & + - 4.84e-9*TC1D(I)*TC1D(I)*TC1D(I)) + + IF((XLAND(I)-1.5).GE.0)THEN + !-------------------------------------- + ! WATER + !-------------------------------------- + ! CALCULATE z0 (znt) + !-------------------------------------- + IF ( PRESENT(ISFTCFLX) ) THEN + IF ( ISFTCFLX .EQ. 0 ) THEN + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 (MISLEADING SUBROUTINE NAME) + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF + ELSEIF ( ISFTCFLX .EQ. 1 .OR. ISFTCFLX .EQ. 2 ) THEN + CALL davis_etal_2008(ZNT(i),UST(i)) + ELSEIF ( ISFTCFLX .EQ. 3 ) THEN + CALL Taylor_Yelland_2001(ZNT(i),UST(i),WSPD(i)) + ELSEIF ( ISFTCFLX .EQ. 4 ) THEN + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 (MISLEADING SUBROUTINE NAME) + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF + ENDIF + ELSE + !DEFAULT TO COARE 3.0/3.5 + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF + ENDIF + + ! add stochastic perturbaction of ZNT + if (spp_pbl==1) then + ZNTstoch(I) = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6) + else + ZNTstoch(I) = ZNT(I) + endif + + !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT + ! AHW: Garrattt formula: Calculate roughness Reynolds number + ! Kinematic viscosity of air (linear approx to + ! temp dependence at sea level) + restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1) + + !-------------------------------------- + !CALCULATE z_t and z_q + !-------------------------------------- + IF ( PRESENT(ISFTCFLX) ) THEN + IF ( ISFTCFLX .EQ. 0 ) THEN + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + !presumably, this will be published soon, but hasn't yet + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) + ENDIF + ELSEIF ( ISFTCFLX .EQ. 1 ) THEN + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) + ENDIF + ELSEIF ( ISFTCFLX .EQ. 2 ) THEN + CALL garratt_1992(z_t(i),z_q(i),ZNTstoch(i),restar,XLAND(I)) + ELSEIF ( ISFTCFLX .EQ. 3 ) THEN + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) + ENDIF + ELSEIF ( ISFTCFLX .EQ. 4 ) THEN + CALL zilitinkevich_1995(ZNTstoch(i),z_t(i),z_q(i),restar,& + UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i)) + ENDIF + ELSE + !DEFAULT TO COARE 3.0/3.5 + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl) + ENDIF + ENDIF + + ELSE + + ! add stochastic perturbaction of ZNT + if (spp_pbl==1) then + ZNTstoch(I) = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6) + else + ZNTstoch(I) = ZNT(I) + endif + + !-------------------------------------- + ! LAND + !-------------------------------------- + !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING DEFAULT ZNT + restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1) + + !-------------------------------------- + !GET z_t and z_q + !-------------------------------------- + !CHECK FOR SNOW/ICE POINTS OVER LAND + !IF ( ZNTSTOCH(i) .LE. SNOWZ0 .AND. TSK(I) .LE. 273.15 ) THEN + IF ( SNOWH(i) .GE. 0.1) THEN + CALL Andreas_2002(ZNTSTOCH(i),visc,ust(i),z_t(i),z_q(i)) + ELSE + IF ( PRESENT(IZ0TLND) ) THEN + IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN + !IF IZ0TLND==4, THEN PSIQ WILL BE RECALCULATED USING + !PAN ET AL (1994), but PSIT FROM ZILI WILL BE USED. + CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,& + UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i)) + ELSEIF ( IZ0TLND .EQ. 2 ) THEN + CALL Yang_2008(ZNTSTOCH(i),z_t(i),z_q(i),UST(i),MOL(I),& + qstar(I),restar,visc,XLAND(I)) + ELSEIF ( IZ0TLND .EQ. 3 ) THEN + !Original MYNN in WRF-ARW used this form: + CALL garratt_1992(z_t(i),z_q(i),ZNTSTOCH(i),restar,XLAND(I)) + ENDIF + ELSE + !DEFAULT TO ZILITINKEVICH + CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,& + UST(I),KARMAN,XLAND(I),0,spp_pbl,rstoch1D(i)) + ENDIF + ENDIF + + ENDIF + zratio(i)=zntstoch(i)/z_t(i) + + !ADD RESISTANCE (SOMEWHAT FOLLOWING JIMENEZ ET AL. (2012)) TO PROTECT AGAINST + !EXCESSIVE FLUXES WHEN USING A LOW FIRST MODEL LEVEL (ZA < 10 m). + !Formerly: GZ1OZ0(I)= LOG(ZA(I)/ZNTstoch(I)) + GZ1OZ0(I)= LOG((ZA(I)+ZNTstoch(I))/ZNTstoch(I)) + GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) + GZ2OZ0(I)= LOG((2.0+ZNTstoch(I))/ZNTstoch(I)) + GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) + GZ10OZ0(I)=LOG((10.+ZNTstoch(I))/ZNTstoch(I)) + GZ10OZt(I)=LOG((10.+z_t(i))/z_t(i)) + + !-------------------------------------------------------------------- + !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS: + ! + ! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.). + ! + ! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: + ! + ! 1. BR .GE. 0.2; + ! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), + ! + ! 2. BR .LT. 0.2 .AND. BR .GT. 0.0; + ! REPRESENTS DAMPED MECHANICAL TURBULENT CONDITIONS + ! (REGIME=2), + ! + ! 3. BR .EQ. 0.0 + ! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), + ! + ! 4. BR .LT. 0.0 + ! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). + ! + !-------------------------------------------------------------------- + IF (BR(I) .GT. 0.0) THEN + IF (BR(I) .GT. 0.2) THEN + !---CLASS 1; STABLE (NIGHTTIME) CONDITIONS: + REGIME(I)=1. + ELSE + !---CLASS 2; DAMPED MECHANICAL TURBULENCE: + REGIME(I)=2. + ENDIF + + !COMPUTE z/L + !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) +! IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN + CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) +! ELSE +! ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I)*UST(I),0.0001)) +! ZOL(I)=MAX(ZOL(I),0.0) +! ZOL(I)=MIN(ZOL(I),2.) +! ENDIF + + !COMPUTE PSIM and PSIH + IF((XLAND(I)-1.5).GE.0)THEN + ! WATER + !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) + !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) + !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) + CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) + ELSE + ! LAND + !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I)) + !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) + !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I)) + CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) + ENDIF + + ! LOWER LIMIT ON PSI IN STABLE CONDITIONS + PSIM(I)=MAX(PSIM(I),psilim) + PSIH(I)=MAX(PSIH(I),psilim) + PSIM10(I)=MAX(10./ZA(I)*PSIM(I), psilim) + PSIH10(I)=MAX(10./ZA(I)*PSIH(I), psilim) + PSIM2(I)=MAX(2./ZA(I)*PSIM(I), psilim) + PSIH2(I)=MAX(2./ZA(I)*PSIH(I), psilim) + ! 1.0 over Monin-Obukhov length + RMOL(I)= ZOL(I)/ZA(I) + + ELSEIF(BR(I) .EQ. 0.) THEN + !========================================================= + !-----CLASS 3; FORCED CONVECTION/NEUTRAL: + !========================================================= + 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) + + !ZOL(I)=0. + IF(UST(I) .LT. 0.01)THEN + ZOL(I)=BR(I)*GZ1OZ0(I) + ELSE + ZOL(I)=KARMAN*GOVRTH(I)*ZA(I)*MOL(I)/(MAX(UST(I)*UST(I),0.001)) + ENDIF + RMOL(I) = ZOL(I)/ZA(I) + + ELSEIF(BR(I) .LT. 0.)THEN + !========================================================== + !-----CLASS 4; FREE CONVECTION: + !========================================================== + REGIME(I)=4. + + !COMPUTE z/L + !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) + !IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN + CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I)) + !ELSE + ! ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I)*UST(I),0.001)) + ! ZOL(I)=MAX(ZOL(I),-19.999) + ! ZOL(I)=MIN(ZOL(I),0.0) + !ENDIF + + ZOL10=10./ZA(I)*ZOL(I) + ZOL2=2./ZA(I)*ZOL(I) + ZOL(I)=MIN(ZOL(I),0.) + ZOL(I)=MAX(ZOL(I),-19.9999) + ZOL10=MIN(ZOL10,0.) + ZOL10=MAX(ZOL10,-19.9999) + ZOL2=MIN(ZOL2,0.) + ZOL2=MAX(ZOL2,-19.9999) + NZOL=INT(-ZOL(I)*100.) + RZOL=-ZOL(I)*100.-NZOL + NZOL10=INT(-ZOL10*100.) + RZOL10=-ZOL10*100.-NZOL10 + NZOL2=INT(-ZOL2*100.) + RZOL2=-ZOL2*100.-NZOL2 + + !COMPUTE PSIM and PSIH + IF((XLAND(I)-1.5).GE.0)THEN + ! WATER + !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) + !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I)) + !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) + CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) + ELSE + ! LAND + !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I)) + !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I)) + CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I)) + ENDIF + + PSIM10(I)=10./ZA(I)*PSIM(I) + PSIH10(I)=10./ZA(I)*PSIH(I) + PSIM2(I)=2./ZA(I)*PSIM(I) + PSIH2(I)=2./ZA(I)*PSIH(I) + + !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND + !---HIGH ROUGHNESS. THIS PREVENTS DENOMINATOR IN FLUXES + !---FROM GETTING TOO SMALL + !PSIH(I)=MIN(PSIH(I),0.9*GZ1OZt(I)) !JOE: less restricitive over forest/urban. + PSIH(I)=MIN(PSIH(I),0.9*GZ1OZ0(I)) + PSIM(I)=MIN(PSIM(I),0.9*GZ1OZ0(I)) + !PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZt(I)) !JOE: less restricitive over forest/urban. + PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZ0(I)) + PSIM2(I)=MIN(PSIM2(I),0.9*GZ2OZ0(I)) + PSIM10(I)=MIN(PSIM10(I),0.9*GZ10OZ0(I)) + PSIH10(I)=MIN(PSIH10(I),0.9*GZ10OZ0(I)) + + RMOL(I) = ZOL(I)/ZA(I) + + ENDIF + + !------------------------------------------------------------ + !-----COMPUTE THE FRICTIONAL VELOCITY: + !------------------------------------------------------------ + ! ZA(1982) EQS(2.60),(2.61). + PSIX(I)=GZ1OZ0(I)-PSIM(I) + PSIX10(I)=GZ10OZ0(I)-PSIM10(I) + ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE + OLDUST = UST(I) + UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX(I) + !NON-AVERAGED: UST(I)=KARMAN*WSPD(I)/PSIX(I) + + ! Compute u* without vconv for use in HFX calc when isftcflx > 0 + WSPDI(I)=MAX(SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)), wmin) + IF ( PRESENT(USTM) ) THEN + USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX(I) + ENDIF + + IF ((XLAND(I)-1.5).LT.0.) THEN !LAND + UST(I)=MAX(UST(I),0.005) !Further relaxing this limit - no need to go lower + !Keep ustm = ust over land. + IF ( PRESENT(USTM) ) USTM(I)=UST(I) + ENDIF + + !------------------------------------------------------------ + !-----COMPUTE THE THERMAL AND MOISTURE RESISTANCE (PSIQ AND PSIT): + !------------------------------------------------------------ + ! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL + ! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 + GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i)) + GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i)) + + PSIT(I) =MAX(GZ1OZt(I)-PSIH(I) ,1.) + PSIT2(I)=MAX(GZ2OZt(I)-PSIH2(I),1.) + resist(I)=PSIT(I) + logres(I)=GZ1OZt(I) + + PSIQ=MAX(LOG((ZA(I)+z_q(i))/z_q(I))-PSIH(I) ,1.0) + PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,1.0) + + IF((XLAND(I)-1.5).LT.0)THEN !Land only + IF ( IZ0TLND .EQ. 4 ) THEN + CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),& + & KARMAN,ZA(I)) + ENDIF + ENDIF + + !---------------------------------------------------- + !COMPUTE THE TEMPERATURE SCALE (or FRICTION TEMPERATURE, T*) + !---------------------------------------------------- + !DTG=TH1D(I)-THGB(I) !SWITCH TO THETA-V + DTG=THV1D(I)-THVGB(I) + OLDTST=MOL(I) + MOL(I)=KARMAN*DTG/PSIT(I)/PRT + !t_star(I) = -HFX(I)/(UST(I)*CPM(I)*RHO1D(I)) + !t_star(I) = MOL(I) + !---------------------------------------------------- + !COMPUTE THE MOISTURE SCALE (or q*) + DQG=(QVSH(i)-qsfc(i))*1000. !(kg/kg -> g/kg) + qstar(I)=KARMAN*DQG/PSIQ/PRT + + !CHECK FOR CONVERGENCE + IF (ITER .GE. 2) THEN + !IF (ABS(OLDUST-UST(I)) .lt. 0.01) THEN + IF (ABS(OLDTST-MOL(I)) .lt. 0.01) THEN + ITER = ITER+ITMAX + ENDIF + + !IF () THEN + ! print*,"ITER:",ITER + ! write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I)," Tstar:",MOL(I) + ! write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I)," DTHV:",THV1D(I)-THVGB(I) + ! write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) + ! write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I)," za:",za(I) + ! write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",QSFC(I)," QVSH(I):",QVSH(I) + ! print*,"VISC=",VISC," Z0:",ZNTstoch(I)," T1D(i):",T1D(i) + ! write(*,*)"=============================================" + !ENDIF + ENDIF + + ITER = ITER + 1 + + ENDDO ! end ITERATION-loop + + ENDDO ! end i-loop + + 1000 format(A,F6.1, A,f6.1, A,f5.1, A,f7.1) + 1001 format(A,F2.0, A,f10.4,A,f5.3, A,f11.5) + 1002 format(A,f7.2, A,f7.2, A,f7.2, A,f10.3) + 1003 format(A,f7.2, A,f7.2, A,f10.3,A,f10.3) + 1004 format(A,f11.3,A,f9.7, A,f9.7, A,f6.2, A,f10.3) + 1005 format(A,f9.2,A,f6.4,A,f7.4,A,f7.4) + + !---------------------------------------------------------- + ! COMPUTE SURFACE HEAT AND MOISTURE FLUXES + !---------------------------------------------------------- + DO I=its,ite + + !For computing the diagnostics and fluxes (below), whether the fluxes + !are turned off or on, we need the following: + PSIX(I)=GZ1OZ0(I)-PSIM(I) + PSIX10(I)=GZ10OZ0(I)-PSIM10(I) + + PSIT(I) =MAX(GZ1OZt(I)-PSIH(I), 1.0) + PSIT2(I)=MAX(GZ2OZt(I)-PSIH2(I),1.0) + PSIT10=MAX(GZ10OZ0(I)-PSIH10(I), 1.0) + + PSIQ=MAX(LOG((ZA(I)+z_q(i))/z_q(I))-PSIH(I) ,1.0) + PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,1.0) + PSIQ10=MAX(GZ10OZ0(I)-PSIH10(I),1.0) + + IF (ISFFLX .LT. 1) THEN + + QFX(i) = 0. + HFX(i) = 0. + FLHC(I) = 0. + FLQC(I) = 0. + LH(I) = 0. + CHS(I) = 0. + CH(I) = 0. + CHS2(i) = 0. + CQS2(i) = 0. + IF(PRESENT(ck) .and. PRESENT(cd) .and. & + &PRESENT(cka) .and. PRESENT(cda)) THEN + Ck(I) = 0. + Cd(I) = 0. + Cka(I)= 0. + Cda(I)= 0. + ENDIF + ELSE + + IF((XLAND(I)-1.5).LT.0)THEN !LAND Only + IF ( IZ0TLND .EQ. 4 ) THEN + CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),& + & KARMAN,ZA(I)) + ENDIF + ENDIF + + !------------------------------------------ + ! CALCULATE THE EXCHANGE COEFFICIENTS FOR HEAT (FLHC) + ! AND MOISTURE (FLQC) + !------------------------------------------ + FLQC(I)=RHO1D(I)*MAVAIL(I)*UST(I)*KARMAN/PSIQ + FLHC(I)=RHO1D(I)*CPM(I)*UST(I)*KARMAN/PSIT(I) + !OLD WAY: + !DTTHX=ABS(TH1D(I)-THGB(I)) + !IF(DTTHX.GT.1.E-5)THEN + ! FLHC(I)=CPM(I)*RHO1D(I)*UST(I)*MOL(I)/(TH1D(I)-THGB(I)) + !ELSE + ! FLHC(I)=0. + !ENDIF + + !---------------------------------- + ! COMPUTE SURFACE MOISTURE FLUX: + !---------------------------------- + QFX(I)=FLQC(I)*(QSFCMR(I)-QV1D(I)) + !JOE: QFX(I)=MAX(QFX(I),0.) !originally did not allow neg QFX + QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX, like MYJ + LH(I)=XLV*QFX(I) + + !---------------------------------- + ! COMPUTE SURFACE HEAT FLUX: + !---------------------------------- + IF(XLAND(I)-1.5.GT.0.)THEN !WATER + HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) + IF ( PRESENT(ISFTCFLX) ) THEN + IF ( ISFTCFLX.NE.0 ) THEN + ! AHW: add dissipative heating term + HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) + ENDIF + ENDIF + ELSEIF(XLAND(I)-1.5.LT.0.)THEN !LAND + HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) + HFX(I)=MAX(HFX(I),-250.) + ENDIF + + !CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) & + ! /XKA+ZA(I)/ZL)-PSIH(I)) + + CHS(I)=UST(I)*KARMAN/PSIT(I) + + ! The exchange coefficient for cloud water is assumed to be the + ! same as that for heat. CH is multiplied by WSPD. + + !ch(i)=chs(i) + ch(i)=flhc(i)/( cpm(i)*RHO1D(i) ) + + !THESE ARE USED FOR 2-M DIAGNOSTICS ONLY + CQS2(I)=UST(I)*KARMAN/PSIQ2 + CHS2(I)=UST(I)*KARMAN/PSIT2(I) + + IF(PRESENT(ck) .and. PRESENT(cd) .and. & + &PRESENT(cka) .and. PRESENT(cda)) THEN + Ck(I)=(karman/psix10(I))*(karman/psiq10) + Cd(I)=(karman/psix10(I))*(karman/psix10(I)) + Cka(I)=(karman/psix(I))*(karman/psiq) + Cda(I)=(karman/psix(I))*(karman/psix(I)) + ENDIF + + ENDIF !end ISFFLX option + + !----------------------------------------------------- + !COMPUTE DIAGNOSTICS + !----------------------------------------------------- + !COMPUTE 10 M WNDS + !----------------------------------------------------- + ! If the lowest model level is close to 10-m, use it + ! instead of the flux-based diagnostic formula. + if (ZA(i) .le. 7.0) then + ! high vertical resolution + if(ZA2(i) .gt. 7.0 .and. ZA2(i) .lt. 13.0) then + !use 2nd model level + U10(I)=U1D2(I) + V10(I)=V1D2(I) + else + U10(I)=U1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) + V10(I)=V1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) + endif + elseif(ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then + !moderate vertical resolution + !U10(I)=U1D(I)*PSIX10(I)/PSIX(I) + !V10(I)=V1D(I)*PSIX10(I)/PSIX(I) + !use neutral-log: + U10(I)=U1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) + V10(I)=V1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I)) + else + ! very coarse vertical resolution + U10(I)=U1D(I)*PSIX10(I)/PSIX(I) + V10(I)=V1D(I)*PSIX10(I)/PSIX(I) + endif + + !----------------------------------------------------- + !COMPUTE 2m T, TH, AND Q + !THESE WILL BE OVERWRITTEN FOR LAND POINTS IN THE LSM + !----------------------------------------------------- + DTG=TH1D(I)-THGB(I) + TH2(I)=THGB(I)+DTG*PSIT2(I)/PSIT(I) + !*** BE CERTAIN THAT THE 2-M THETA IS BRACKETED BY + !*** THE VALUES AT THE SURFACE AND LOWEST MODEL LEVEL. + IF ((TH1D(I)>THGB(I) .AND. (TH2(I)TH1D(I))) .OR. & + (TH1D(I)THGB(I) .OR. TH2(I)QSFCMR(I) .AND. (Q2(I)QV1D(I))) .OR. & + (QV1D(I)QSFCMR(I) .OR. Q2(I) 1200. .OR. HFX(I) < -700.)THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "HFX: ",HFX(I) + yesno = 1 + ENDIF + IF (LH(I) > 1200. .OR. LH(I) < -700.)THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "LH: ",LH(I) + yesno = 1 + ENDIF + IF (UST(I) < 0.0 .OR. UST(I) > 4.0 )THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "UST: ",UST(I) + yesno = 1 + ENDIF + IF (WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0)THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "WSTAR: ",WSTAR(I) + yesno = 1 + ENDIF + IF (RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 )THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "rho: ",RHO1D(I) + yesno = 1 + ENDIF + IF (QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >40.)THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "QSFC: ",QSFC(I) + yesno = 1 + ENDIF + IF (PBLH(I)<0. .OR. PBLH(I)>6000.)THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J, "PBLH: ",PBLH(I) + yesno = 1 + ENDIF + + IF (yesno == 1) THEN + print*," OTHER INFO:" + write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),& + " Tstar:",MOL(I) + write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),& + " DTHV:",THV1D(I)-THVGB(I) + write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",& + ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) + write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I),& + " za:",za(I) + write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",& + QSFC(I)," QVSH(I):",QVSH(I) + print*,"PSIX=",PSIX(I)," Z0:",ZNTstoch(I)," T1D(i):",T1D(i) + write(*,*)"=============================================" + ENDIF + ENDIF + + ENDDO !end i-loop + +END SUBROUTINE SFCLAY1D_mynn +!------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns the thermal and moisture roughness lengths +!! from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over +!! land and water, respectively. +!! +!! MODS: +!! 20120705 : added IZ0TLND option. Note: This option was designed +!! to work with the Noah LSM and may be specific for that +!! LSM only. Tests with RUC LSM showed no improvements. + SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,& + & landsea,IZ0TLND2,spp_pbl,rstoch) + + IMPLICIT NONE + REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea + INTEGER, OPTIONAL, INTENT(IN):: IZ0TLND2 + REAL, INTENT(OUT) :: Zt,Zq + REAL :: CZIL !=0.100 in Chen et al. (1997) + !=0.075 in Zilitinkevich (1995) + !=0.500 in Lemone et al. (2008) + INTEGER, INTENT(IN) :: spp_pbl + REAL, INTENT(IN) :: rstoch + + + IF (landsea-1.5 .GT. 0) THEN !WATER + + !THIS IS BASED ON Zilitinkevich, Grachev, and Fairall (2001; + !Their equations 15 and 16). + IF (restar .LT. 0.1) THEN + Zt = Z_0*EXP(KARMAN*2.0) + Zt = MIN( Zt, 6.0e-5) + Zt = MAX( Zt, 2.0e-9) + Zq = Z_0*EXP(KARMAN*3.0) + Zq = MIN( Zq, 6.0e-5) + Zq = MAX( Zq, 2.0e-9) + ELSE + Zt = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-3.2)) + Zt = MIN( Zt, 6.0e-5) + Zt = MAX( Zt, 2.0e-9) + Zq = Z_0*EXP(-KARMAN*(4.0*SQRT(restar)-4.2)) + Zq = MIN( Zt, 6.0e-5) + Zq = MAX( Zt, 2.0e-9) + ENDIF + + ELSE !LAND + + !Option to modify CZIL according to Chen & Zhang, 2009 + IF ( IZ0TLND2 .EQ. 1 ) THEN + CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) ) + ELSE + CZIL = 0.075 !0.10 + END IF + + Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) + Zt = MIN( Zt, Z_0/2.) + + Zq = Z_0*EXP(-KARMAN*CZIL*SQRT(restar)) + Zq = MIN( Zq, Z_0/2.) + +! perturb thermal and moisture roughness lenth by +/-50% +! uses same perturbation pattern for perturbing cloud fraction +! and turbulent mixing length (module_sf_mynn.F), but +! twice the amplitude; +! multiplication with -1.0 anticorrelates patterns + if (spp_pbl==1) then + Zt = Zt + Zt * 2.0 * rstoch + Zt = MAX(Zt, 0.001) + Zq = Zt + endif + + ENDIF + + return + + END SUBROUTINE zilitinkevich_1995 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!! This subroutine returns the resistance (PSIQ) for moisture +!! exchange. This is a modified form originating from Pan et al.. +!! (1994) but modified according to tests in both the RUC model. +!! and WRF-ARW. Note that it is very similar to Carlson and +!! Boland (1978) model (include below in comments) but has an +!! extra molecular layer (a third layer) instead of two layers. + SUBROUTINE Pan_etal_1994(PSIQ,PSIQ2,ustar,psih,psih2,KARMAN,Z1) + + IMPLICIT NONE + REAL, INTENT(IN) :: Z1,ustar,KARMAN,psih,psih2 + REAL, INTENT(OUT) :: psiq,psiq2 + REAL, PARAMETER :: Cpan=1.0 !was 20.8 in Pan et al 1994 + REAL, PARAMETER :: ZL=0.01 + REAL, PARAMETER :: ZMUs=0.2E-3 + REAL, PARAMETER :: XKA = 2.4E-5 + + !PAN et al. (1994): 3-layer model, as in paper: + !ZMU = Cpan*XKA/(KARMAN*UST(I)) + !PSIQ =MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & + ! & Z1/ZL) - PSIH,2.0) + !PSIQ2=MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + & + ! & 2./ZL) - PSIH2,2.0) + !MODIFIED FORM: + PSIQ =MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*Z1)/XKA + & + & Z1/ZL) - PSIH,2.0) + PSIQ2=MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*2.0)/XKA + & + & 2./ZL) - PSIH2,2.0) + + !CARLSON AND BOLAND (1978): 2-layer model + !PSIQ =MAX(LOG(KARMAN*ustar*Z1/XKA + Z1/ZL)-PSIH ,2.0) + !PSIQ2=MAX(LOG(KARMAN*ustar*2./XKA + 2./ZL)-PSIH2 ,2.0) + + END SUBROUTINE Pan_etal_1994 +!-------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!! This formulation for roughness length was designed to match. +!! the labratory experiments of Donelan et al. (2004). +!! This is an update version from Davis et al. 2008, which +!! corrects a small-bias in Z_0 (AHW real-time 2012). + SUBROUTINE davis_etal_2008(Z_0,ustar) + + IMPLICIT NONE + REAL, INTENT(IN) :: ustar + REAL, INTENT(OUT) :: Z_0 + REAL :: ZW, ZN1, ZN2 + REAL, PARAMETER :: G=9.81, OZO=1.59E-5 + + !OLD FORM: Z_0 = 10.*EXP(-10./(ustar**(1./3.))) + !NEW FORM: + + ZW = MIN((ustar/1.06)**(0.3),1.0) + ZN1 = 0.011*ustar*ustar/G + OZO + ZN2 = 10.*exp(-9.5*ustar**(-.3333)) + & + 0.11*1.5E-5/AMAX1(ustar,0.01) + Z_0 = (1.0-ZW) * ZN1 + ZW * ZN2 + + Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by + Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) + + return + + END SUBROUTINE davis_etal_2008 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!>This formulation for roughness length was designed account for. +!!wave steepness. + SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) + + IMPLICIT NONE + REAL, INTENT(IN) :: ustar,wsp10 + REAL, INTENT(OUT) :: Z_0 + REAL, parameter :: g=9.81, pi=3.14159265 + REAL :: hs, Tp, Lp + + !hs is the significant wave height + hs = 0.0248*(wsp10**2.) + !Tp dominant wave period + Tp = 0.729*MAX(wsp10,0.1) + !Lp is the wavelength of the dominant wave + Lp = g*Tp**2/(2*pi) + + Z_0 = 1200.*hs*(hs/Lp)**4.5 + Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by + Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) + + return + + END SUBROUTINE Taylor_Yelland_2001 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!>This version of Charnock's relation employs a varying +!! Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. +!! The Charnock parameter CZC is varied from .011 to .018. +!! between 10-m wsp = 10 and 18.. + SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) + + IMPLICIT NONE + REAL, INTENT(IN) :: ustar, visc, wsp10, zu + REAL, INTENT(OUT) :: Z_0 + REAL, PARAMETER :: G=9.81, CZO2=0.011 + REAL :: CZC !variable charnock "constant" + REAL :: wsp10m ! logarithmically calculated 10 m + + wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) + CZC = CZO2 + 0.007*MIN(MAX((wsp10m-10.)/8., 0.), 1.0) + + Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.05)) + Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by + Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) + + return + + END SUBROUTINE charnock_1955 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This version of Charnock's relation employs a varying +!!Charnock parameter, taken from COARE 3.5 [Edson et al. (2001, JPO)]. +!!The Charnock parameter CZC is varied from about .005 to .028 +!!between 10-m wind speeds of 6 and 19 m/s. + SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) + + IMPLICIT NONE + REAL, INTENT(IN) :: ustar, visc, wsp10, zu + REAL, INTENT(OUT) :: Z_0 + REAL, PARAMETER :: G=9.81 + REAL, PARAMETER :: m=0.017, b=-0.005 + REAL :: CZC ! variable charnock "constant" + REAL :: wsp10m ! logarithmically calculated 10 m + + wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) + wsp10m = MIN(19., wsp10m) + CZC = m*wsp10m + b + CZC = MAX(CZC, 0.0) + + Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.07)) + Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by + Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) + + return + + END SUBROUTINE edson_etal_2013 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This formulation for the thermal and moisture roughness lengths +!! (Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). +!!This formula comes from Fairall et al. (2003). It is modified from +!!the original Garratt-Brutsaert model to better fit the COARE/HEXMAX +!!data. The formula for land uses a constant ratio (Z_0/7.4) taken +!!from Garratt (1992). + SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) + + IMPLICIT NONE + REAL, INTENT(IN) :: Ren, Z_0,landsea + REAL, INTENT(OUT) :: Zt,Zq + REAL :: Rq + REAL, PARAMETER :: e=2.71828183 + + IF (landsea-1.5 .GT. 0) THEN !WATER + + Zt = Z_0*EXP(2.0 - (2.48*(Ren**0.25))) + Zq = Z_0*EXP(2.0 - (2.28*(Ren**0.25))) + + Zq = MIN( Zq, 5.5e-5) + Zq = MAX( Zq, 2.0e-9) + Zt = MIN( Zt, 5.5e-5) + Zt = MAX( Zt, 2.0e-9) !same lower limit as ECMWF + ELSE !LAND + Zq = Z_0/(e**2.) !taken from Garratt (1980,1992) + Zt = Zq + ENDIF + + return + + END SUBROUTINE garratt_1992 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!>This formulation for thermal and moisture roughness length (Zt and Zq) +!! as a function of the roughness Reynolds number (Ren) comes from the +!! COARE3.0 formulation, empirically derived from COARE and HEXMAX data +!! [Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this +!!relationship overestimated the scalar roughness lengths for low Reynolds +!!number flows, so an optional smooth flow relationship, taken from Garratt +!!(1992, p. 102), is available for flows with Ren < 2. +!! +!!This is for use over water only. + SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc) + + IMPLICIT NONE + REAL, INTENT(IN) :: Ren,ustar,visc + REAL, INTENT(OUT) :: Zt,Zq + + IF (Ren .le. 2.) then + + Zt = (5.5e-5)*(Ren**(-0.60)) + Zq = Zt + !FOR SMOOTH SEAS, CAN USE GARRATT + !Zq = 0.2*visc/MAX(ustar,0.1) + !Zq = 0.3*visc/MAX(ustar,0.1) + + ELSE + + !FOR ROUGH SEAS, USE COARE + Zt = (5.5e-5)*(Ren**(-0.60)) + Zq = Zt + + ENDIF + + Zt = MIN(Zt,1.0e-4) + Zt = MAX(Zt,2.0e-9) + + Zq = MIN(Zt,1.0e-4) + Zq = MAX(Zt,2.0e-9) + + return + + END SUBROUTINE fairall_etal_2003 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This formulation for thermal and moisture roughness length (Zt and Zq) +!! as a function of the roughness Reynolds number (Ren) comes from the +!! COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data +!! [Fairall et al. (2014? coming soon, not yet published as of July 2014)]. +!! This is for use over water only. + SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl) + + IMPLICIT NONE + REAL, INTENT(IN) :: Ren,ustar,visc,rstoch + INTEGER, INTENT(IN):: spp_pbl + REAL, INTENT(OUT) :: Zt,Zq + + !Zt = (5.5e-5)*(Ren**(-0.60)) + Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72)) + Zq = Zt + + IF (spp_pbl ==1) THEN + Zt = MAX(Zt + Zt*2.0*rstoch,2.0e-9) + Zq = MAX(Zt + Zt*2.0*rstoch,2.0e-9) + ELSE + Zt = MAX(Zt,2.0e-9) + Zq = MAX(Zt,2.0e-9) + ENDIF + + return + + END SUBROUTINE fairall_etal_2014 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This is a modified version of Yang et al (2002 QJRMS, 2008 JAMC) +!! and Chen et al (2010, J of Hydromet). Although it was originally +!! designed for arid regions with bare soil, it is modified +!! here to perform over a broader spectrum of vegetation. +!! +!!The original formulation relates the thermal roughness length (Zt) +!!to u* and T*: +!! +!! Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar)**0.25)) +!! +!!where ht = Renc*visc/ustar and the critical Reynolds number +!!(Renc) = 70. Beta was originally = 10 (2002 paper) but was revised +!!to 7.2 (in 2008 paper). Their form typically varies the +!!ratio Z0/Zt by a few orders of magnitude (1-1E4). +!! +!!This modified form uses beta = 1.5 and a variable Renc (function of Z_0), +!!so zt generally varies similarly to the Zilitinkevich form (with Czil = 0.1) +!!for very small or negative surface heat fluxes but can become close to the +!!Zilitinkevich with Czil = 0.2 for very large HFX (large negative T*). +!!Also, the exponent (0.25) on tstar was changed to 1.0, since we found +!!Zt was reduced too much for low-moderate positive heat fluxes. +!! +!!This should only be used over land! + SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc,landsea) + + IMPLICIT NONE + REAL, INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc, landsea + REAL :: ht, &! roughness height at critical Reynolds number + tstar2, &! bounded T*, forced to be non-positive + qstar2, &! bounded q*, forced to be non-positive + Z_02, &! bounded Z_0 for variable Renc2 calc + Renc2 ! variable Renc, function of Z_0 + REAL, INTENT(OUT) :: Zt,Zq + REAL, PARAMETER :: Renc=300., & !old constant Renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for Renc2 function + b=691. !y-intercept for Renc2 function + + Z_02 = MIN(Z_0,0.5) + Z_02 = MAX(Z_02,0.04) + Renc2= b + m*log(Z_02) + ht = Renc2*visc/MAX(ustar,0.01) + tstar2 = MIN(tstar, 0.0) + qstar2 = MIN(qst,0.0) + + Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar2)**1.0)) + Zq = ht * EXP(-beta*(ustar**0.5)*(ABS(qstar2)**1.0)) + !Zq = Zt + + Zt = MIN(Zt, Z_0/2.0) + Zq = MIN(Zq, Z_0/2.0) + + return + + END SUBROUTINE Yang_2008 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This is taken from Andreas (2002; J. of Hydromet) and +!! Andreas et al. (2005; BLM). +!! +!! This should only be used over snow/ice! + SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) + + IMPLICIT NONE + REAL, INTENT(IN) :: Z_0, bvisc, ustar + REAL, INTENT(OUT) :: Zt, Zq + REAL :: Ren2, zntsno + + REAL, PARAMETER :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & + bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & + bt2_s=0.0, bt2_t=0.0, bt2_r=-0.183 + + REAL, PARAMETER :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & + bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & + bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 + + !Calculate zo for snow (Andreas et al. 2005, BLM) + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)/9.8) * & + (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) + Ren2 = ustar*zntsno/bvisc + + ! Make sure that Re is not outside of the range of validity + ! for using their equations + IF (Ren2 .gt. 1000.) Ren2 = 1000. + + IF (Ren2 .le. 0.135) then + + Zt = zntsno*EXP(bt0_s + bt1_s*LOG(Ren2) + bt2_s*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_s + bq1_s*LOG(Ren2) + bq2_s*LOG(Ren2)**2) + + ELSE IF (Ren2 .gt. 0.135 .AND. Ren2 .lt. 2.5) then + + Zt = zntsno*EXP(bt0_t + bt1_t*LOG(Ren2) + bt2_t*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_t + bq1_t*LOG(Ren2) + bq2_t*LOG(Ren2)**2) + + ELSE + + Zt = zntsno*EXP(bt0_r + bt1_r*LOG(Ren2) + bt2_r*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_r + bq1_r*LOG(Ren2) + bq2_r*LOG(Ren2)**2) + + ENDIF + + return + + END SUBROUTINE Andreas_2002 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns the stability functions based off +!! of Hogstrom (1996). + SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL, Zt, Z_0, Za + REAL, INTENT(OUT) :: psi_m, psi_h + REAL :: x, x0, y, y0, zmL, zhL + + zmL = Z_0*zL/Za + zhL = Zt*zL/Za + + IF (zL .gt. 0.) THEN !STABLE (not well tested - seem large) + + psi_m = -5.3*(zL - zmL) + psi_h = -8.0*(zL - zhL) + + ELSE !UNSTABLE + + x = (1.-19.0*zL)**0.25 + x0= (1.-19.0*zmL)**0.25 + y = (1.-11.6*zL)**0.5 + y0= (1.-11.6*zhL)**0.5 + + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + &LOG((1.+x**2.)/(1.+x0**2.)) - & + &2.0*ATAN(x) + 2.0*ATAN(x0) + psi_h = 2.*LOG((1.+y)/(1.+y0)) + + ENDIF + + return + + END SUBROUTINE PSI_Hogstrom_1996 +!-------------------------------------------------------------------- +!> \ingroup module_sf_mynn_mod +!> This subroutine returns the stability functions based off +!! of Hogstrom (1996), but with different constants compatible +!! with Dyer and Hicks (1970/74?). This formulation is used for +!! testing/development by Nakanishi (personal communication). + SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL, Zt, Z_0, Za + REAL, INTENT(OUT) :: psi_m, psi_h + REAL :: x, x0, y, y0, zmL, zhL + + zmL = Z_0*zL/Za !Zo/L + zhL = Zt*zL/Za !Zt/L + + IF (zL .gt. 0.) THEN !STABLE + + psi_m = -5.0*(zL - zmL) + psi_h = -5.0*(zL - zhL) + + ELSE !UNSTABLE + + x = (1.-16.*zL)**0.25 + x0= (1.-16.*zmL)**0.25 + + y = (1.-16.*zL)**0.5 + y0= (1.-16.*zhL)**0.5 + + psi_m = 2.*LOG((1.+x)/(1.+x0)) + & + &LOG((1.+x**2.)/(1.+x0**2.)) - & + &2.0*ATAN(x) + 2.0*ATAN(x0) + psi_h = 2.*LOG((1.+y)/(1.+y0)) + + ENDIF + + return + + END SUBROUTINE PSI_DyerHicks +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns the stability functions based off +!! of Beljaar and Holtslag 1991, which is an extension of Holtslag +!! and Debruin 1989. + SUBROUTINE PSI_Beljaars_Holtslag_1991(psi_m, psi_h, zL) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL + REAL, INTENT(OUT) :: psi_m, psi_h + REAL, PARAMETER :: a=1., b=0.666, c=5., d=0.35 + + IF (zL .lt. 0.) THEN !UNSTABLE + + WRITE(*,*)"WARNING: Universal stability functions from" + WRITE(*,*)" Beljaars and Holtslag (1991) should only" + WRITE(*,*)" be used in the stable regime!" + psi_m = 0. + psi_h = 0. + + ELSE !STABLE + + psi_m = -(a*zL + b*(zL -(c/d))*exp(-d*zL) + (b*c/d)) + psi_h = -((1.+.666*a*zL)**1.5 + & + b*(zL - (c/d))*exp(-d*zL) + (b*c/d) -1.) + + ENDIF + + return + + END SUBROUTINE PSI_Beljaars_Holtslag_1991 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns the stability functions come from +!! Zilitinkevich and Esau (2007, BM), which are formulatioed from the +!! "generalized similarity theory" and tuned to the LES DATABASE64 +!! to determine their dependence on z/L. + SUBROUTINE PSI_Zilitinkevich_Esau_2007(psi_m, psi_h, zL) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL + REAL, INTENT(OUT) :: psi_m, psi_h + REAL, PARAMETER :: Cm=3.0, Ct=2.5 + + IF (zL .lt. 0.) THEN !UNSTABLE + + WRITE(*,*)"WARNING: Universal stability function from" + WRITE(*,*)" Zilitinkevich and Esau (2007) should only" + WRITE(*,*)" be used in the stable regime!" + psi_m = 0. + psi_h = 0. + + ELSE !STABLE + + psi_m = -Cm*(zL**(5./6.)) + psi_h = -Ct*(zL**(4./5.)) + + ENDIF + + return + + END SUBROUTINE PSI_Zilitinkevich_Esau_2007 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns the flux-profile relationships +!! of Businger el al. 1971. + SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL + REAL, INTENT(OUT) :: psi_m, psi_h + REAL :: x, y + REAL, PARAMETER :: Pi180 = 3.14159265/180. + + IF (zL .lt. 0.) THEN !UNSTABLE + + x = (1. - 15.0*zL)**0.25 + y = (1. - 9.0*zL)**0.5 + + psi_m = LOG(((1.+x)/2.)**2.) + & + &LOG((1.+x**2.)/2.) - & + &2.0*ATAN(x) + Pi180*90. + psi_h = 2.*LOG((1.+y)/2.) + + ELSE !STABLE + + psi_m = -4.7*zL + psi_h = -(4.7/0.74)*zL + + ENDIF + + return + + END SUBROUTINE PSI_Businger_1971 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!> This subroutine returns flux-profile relatioships based off +!!of Lobocki (1993), which is derived from the MY-level 2 model. +!!Suselj and Sood (2010) applied the surface layer length scales +!!from Nakanishi (2001) to get this new relationship. These functions +!!are more agressive (larger magnitude) than most formulations. They +!!showed improvement over water, but untested over land. + SUBROUTINE PSI_Suselj_Sood_2010(psi_m, psi_h, zL) + + IMPLICIT NONE + REAL, INTENT(IN) :: zL + REAL, INTENT(OUT) :: psi_m, psi_h + REAL, PARAMETER :: Rfc=0.19, Ric=0.183, PHIT=0.8 + + IF (zL .gt. 0.) THEN !STABLE + + psi_m = -(zL/Rfc + 1.1223*EXP(1.-1.6666/zL)) + !psi_h = -zL*Ric/((Rfc**2.)*PHIT) + 8.209*(zL**1.1091) + !THEIR EQ FOR PSI_H CRASHES THE MODEL AND DOES NOT MATCH + !THEIR FIG 1. THIS EQ (BELOW) MATCHES THEIR FIG 1 BETTER: + psi_h = -(zL*Ric/((Rfc**2.)*5.) + 7.09*(zL**1.1091)) + + ELSE !UNSTABLE + + psi_m = 0.9904*LOG(1. - 14.264*zL) + psi_h = 1.0103*LOG(1. - 16.3066*zL) + + ENDIF + + return + + END SUBROUTINE PSI_Suselj_Sood_2010 +!-------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!>This subroutine returns a more robust z/L that best matches +!! the z/L from Hogstrom (1996) for unstable conditions and Beljaars +!! and Holtslag (1991) for stable conditions. + SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt) + + IMPLICIT NONE + REAL, INTENT(OUT) :: zL + REAL, INTENT(IN) :: Rib, zaz0, z0zt + REAL :: alfa, beta, zaz02, z0zt2 + REAL, PARAMETER :: au11=0.045, bu11=0.003, bu12=0.0059, & + &bu21=-0.0828, bu22=0.8845, bu31=0.1739, & + &bu32=-0.9213, bu33=-0.1057 + REAL, PARAMETER :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,& + &aw22=52.50, bw11=-0.0539, bw12=1.540, & + &bw21=-0.669, bw22=-3.282 + REAL, PARAMETER :: as11=0.7529, as21=14.94, bs11=0.1569,& + &bs21=-0.3091, bs22=-1.303 + + !set limits according to Li et al (2010), p 157. + zaz02=zaz0 + IF (zaz0 .lt. 100.0) zaz02=100. + IF (zaz0 .gt. 100000.0) zaz02=100000. + + !set more limits according to Li et al (2010) + z0zt2=z0zt + IF (z0zt .lt. 0.5) z0zt2=0.5 + IF (z0zt .gt. 100.0) z0zt2=100. + + alfa = LOG(zaz02) + beta = LOG(z0zt2) + + IF (Rib .le. 0.0) THEN + zL = au11*alfa*Rib**2 + ( & + & (bu11*beta + bu12)*alfa**2 + & + & (bu21*beta + bu22)*alfa + & + & (bu31*beta**2 + bu32*beta + bu33))*Rib + !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL + zL = MAX(zL,-15.) !LIMITS SET ACCORDING TO Li et al (2010) + zL = MIN(zL,0.) !Figure 1. + ELSEIF (Rib .gt. 0.0 .AND. Rib .le. 0.2) THEN + zL = ((aw11*beta + aw12)*alfa + & + & (aw21*beta + aw22))*Rib**2 + & + & ((bw11*beta + bw12)*alfa + & + & (bw21*beta + bw22))*Rib + !if(zL .LT. 0 .OR. zl .GT. 4)print*,"VIOLATION 00.2:",zL + zL = MIN(zL,20.) !LIMITS ACCORDING TO Li et al (2010), THIER + !FIGUE 1C. + zL = MAX(zL,1.) + ENDIF + + return + + END SUBROUTINE Li_etal_2010 + +!------------------------------------------------------------------- +!>\ingroup module_sf_mynn_mod +!! This subroutine adds pbl modules so they can be optimized in pbl code + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, & + & thl, qw, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf,& + & qc_bl1D, cldfra_bl1D, & + & PBLH1,HFX1, & + & Vt, Vq, th, sgm) + +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + REAL, INTENT(IN) :: dx,PBLH1,HFX1 + REAL, DIMENSION(kts:kte), INTENT(IN) :: dz + REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & + &tsq, qsq, cov, th + + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm + + REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D + DOUBLE PRECISION :: t3sq, r3sq, c3sq + + REAL :: qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt + INTEGER :: i,j,k + + REAL :: erf + + !JOE: NEW VARIABLES FOR ALTERNATE SIGMA + REAL::dth,dtl,dqw,dzk + REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el + + !JOE: variables for BL clouds + REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit + REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) + REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds + REAL :: RH_00L, RH_00O, phi_dz, lfac + REAL, PARAMETER :: cdz = 2.0 + REAL, PARAMETER :: mdz = 1.5 + + !JAYMES: variables for tropopause-height estimation + REAL :: theta1, theta2, ht1, ht2 + INTEGER :: k_tropo + + REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 + + k_tropo=5 + + zagl = 0. + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (0) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + + DO k = kts,kte-1 + t = th(k)*exner(k) + + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/(p(k)-ep_3*esat) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds + ! at the end of this subroutine. + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq(k) = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds + !than e-10 + sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq(k) / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + END DO + + CASE (1, -1) !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/(p(k)-ep_3*esat) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & + b2 * MAX(Sh(k),0.03))/4. * & + (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq(k) = qw(k) -qsl + q1(k) = qmq(k) / sgm(k) + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + END DO + + CASE (2, -2) + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !JAYMES- this added 27 Apr 2015 + DO k = kts,kte-1 + t = th(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat = esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/(p(k)-ep_3*esat) + !dqw/dT: Clausius-Clapeyron + dqsl = qsl*ep_2*ev/( rd*t**2 ) + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) + + alp(k) = 1.0/( 1.0+dqsl*xlvcp ) + bet(k) = dqsl*exner(k) + + xl = xl_blend(t) ! obtain latent heat + + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + + qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) + + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + + cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 + ! in CB02 + zagl = zagl + dz(k) + ls_min = MIN(MAX(zagl,25.),300.) ! Let this be the minimum possible length scale: + ! 25 m < ls_min(=zagl) < 300 m + lfac=MIN(4.25+dx/4000.,6.) ! A dx-dependent multiplier for the master length scale: + ! lfac(750 m) = 4.4 + ! lfac(3 km) = 5.0 + ! lfac(13 km) = 6.0 + + ls = MAX(MIN(lfac*el(k),900.),ls_min) ! Bounded: ls_min < ls < 900 m + ! Note: CB02 use 900 m as a constant free-atmosphere length scale. + ! Above 300 m AGL, ls_min remains 300 m. For dx = 3 km, the + ! MYNN master length scale (el) must exceed 60 m before ls + ! becomes responsive to el, otherwise ls = ls_min = 300 m. + + sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! CB02 use a multiplier of 0.2, but 0.225 is chosen + ! based on tests + + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + + cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + + END DO + END SELECT + + zagl = 0. + RHsum=0. + RHnum=0. + RHmean=0.1 !initialize with small value for small PBLH cases + damp =0 + PBLH2=MAX(10.,PBLH1) + + SELECT CASE(bl_mynn_cloudpdf) + + CASE (-1 : 1) ! ORIGINAL MYNN PARTIAL-CONDENSATION SCHEME + ! OR KUWANO ET AL. + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + !q1=0. + !cld(k)=0. + + !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). + IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN + RHsum=RHsum+RH(k) + RHnum=RHnum+1.0 + RHmean=RHsum/RHnum + ENDIF + RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) + if (HFX1 > HFXmin) then + cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 + else + cld9=0.0 + endif + + edown=PBLH2*.1 + !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX + !(somewhat following results from Zhang and Klein (2013, JAS)) + Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac + if (zagl < PBLH2-edown) then + damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) + elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then + damp=1. + elseif (zagl >= PBLH2+Hshcu)then + damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) + endif + cldfra_bl1D(k)=cld9*damp + !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !use alternate cloud fraction to estimate qc for use in BL clouds-radiation + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 + qc_bl1D(k)=ql(k)*damp + !now recompute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cld(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) + rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + CASE ( 2, -2) + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + ! "fng" represents the non-Gaussian contribution to the liquid + ! water flux; these formulations are from Cuijpers and Bechtold + ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, + ! hereafter BCMT95 + DO k = kts,kte-1 + t = th(k)*exner(k) + q1k = q1(k) + zagl = zagl + dz(k) + IF (q1k < 0.) THEN + ql (k) = sgm(k)*EXP(1.2*q1k-1) + ELSE IF (q1k > 2.) THEN + ql (k) = sgm(k)*q1k + ELSE + ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ENDIF + + !Next, adjust our initial estimates of cldfra and ql based + !on tropopause-height and PBLH considerations + !JAYMES: added 4 Nov 2016 + if ((cld(k) .gt. 0.) .or. (ql(k) .gt. 0.)) then + if (k .le. k_tropo) then + !At and below tropopause: impose an upper limit on ql; assume that + !a maximum of 0.5 percent supersaturation in water vapor can be + !available for cloud production + ql_limit = 0.005 * qsat_blend( th(k)*exner(k), p(k) ) + ql(k) = MIN( ql(k), ql_limit ) + else + !Above tropopause: eliminate subgrid clouds from CB scheme + cld(k) = 0. + ql(k) = 0. + endif + endif + + !Buoyancy-flux-related calculations follow... + ! "Fng" represents the non-Gaussian transport factor + ! (non-dimensional) from from Bechtold et al. 1995 + ! (hereafter BCMT95), section 3(c). Their suggested + ! forms for Fng (from their Eq. 20) are: + ! For purposes of the buoyancy flux in stratus, we will use Fng = 1 + Fng = 1. + + xl = xl_blend(t) + bb = b(k)*t/th(k) ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*th(k) + beta = (th(k)/t)*(xl/cp) - 1.61*th(k) + + vt(k) = qww - cld(k)*beta*bb*Fng - 1. + vq(k) = alpha + cld(k)*beta*a(k)*Fng - tv0 + ! vt and vq correspond to beta-theta and beta-q, respectively, + ! in NN09, Eq. B8. They also correspond to the bracketed + ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ! increase the cloud fraction estimate below PBLH+1km + if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.8*cld(k) ) + ! return a cloud condensate and cloud fraction for icloud_bl option: + cldfra_bl1D(k) = cld(k) + qc_bl1D(k) = ql(k) + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + + END DO + + END SELECT !end cloudPDF option + + !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS. + IF (bl_mynn_cloudpdf .LT. 0) THEN + DO k = kts,kte-1 + cldfra_bl1D(k) = 0.0 + qc_bl1D(k) = 0.0 + END DO + ENDIF + + cld(kte) = cld(kte-1) + ql(kte) = ql(kte-1) + vt(kte) = vt(kte-1) + vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + cldfra_bl1D(kte)=0. + + RETURN + + END SUBROUTINE mym_condensation + +! ================================================================== + + +END MODULE module_sf_mynn + diff --git a/physics/sfcsub.F b/physics/sfcsub.F new file mode 100644 index 000000000..7c78707f5 --- /dev/null +++ b/physics/sfcsub.F @@ -0,0 +1,8745 @@ +!>\file sfcsub.F +!! This file contains gribcode for each parameter. + + +!>\defgroup mod_sfcsub_mod GFS sfcsub Module +!!\ingroup Noah_LSM +!> @{ +!>\ingroup mod_sfcsub +!! This module contains grib code for each parameter-used in subroutines sfccycle() +!! and setrmsk(). + module sfccyc_module + implicit none + save +! +! grib code for each parameter - used in subroutines sfccycle and setrmsk. +! + integer kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla, + & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg, + & kpdvet,kpdsot + &, kpdvmn,kpdvmx,kpdslp,kpdabs + &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) + parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, +! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, + 1 kpdais=91, kpdtg3=11, kpdplr=224, + 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, + 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, +!cbosu max snow albedo uses a grib id number of 159, not 255. + & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, + & kpdvet=225, kpdsot=224,kpdabs_1=159, + & kpdsnd=66 ) +! + integer, parameter :: kpdalb_0(4)=(/212,215,213,216/) + integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) + integer, parameter :: kpdalf(2)=(/214,217/) +! + integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer :: veg_type_landice + integer :: soil_type_landice +! + end module sfccyc_module + +!>\ingroup mod_sfcsub + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc + &, iy,im,id,ih,fh + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl + &, sihfcs,sicfcs,sitfcs + &, swdfcs,slcfcs + &, vmnfcs,vmxfcs,slpfcs,absfcs + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs + &, vegfcs,vetfcs,sotfcs,alffcs + &, cvfcs,cvbfcs,cvtfcs,me,nlunit + &, sz_nml,input_nml_file + &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) +! + use machine , only : kind_io8,kind_io4 + use sfccyc_module + implicit none + character(len=*), intent(in) :: tile_num_ch + integer,intent(in) :: i_index(len), j_index(len) + logical use_ufo, nst_anl + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, + & orolmx,orolmn,oroomx,oroomn,orosmx, + & orosmn,oroimx,oroimn,orojmx,orojmn, + & alblmx,alblmn,albomx,albomn,albsmx, + & albsmn,albimx,albimn,albjmx,albjmn, + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, + & snolmx,snolmn,snoomx,snoomn,snosmx, + & snosmn,snoimx,snoimn,snojmx,snojmn, + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, + & zorsmn,zorimx,zorimn,zorjmx, zorjmn, + & plrlmx,plrlmn,plromx,plromn,plrsmx, + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, + & stclmx,stclmn,stcomx,stcomn,stcsmx, + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, + & smclmx,smclmn,smcomx,smcomn,smcsmx, + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, + & veglmx,veglmn,vegomx,vegomn,vegsmx, + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, + & alslmx,alslmn,alsomx,alsomn,alssmx, + & alssmn,alsimx,alsimn,alsjmx,alsjmn, + & epstsf,epsalb,epssno,epswet,epszor, + & epsplr,epsoro,epssmc,epsscv,eptsfc, + & epstg3,epsais,epsacn,epsveg,epsvet, + & epssot,epsalf,qctsfs,qcsnos,qctsfi, + & aislim,snwmin,snwmax,cplrl,cplrs, + & cvegl,czors,csnol,csnos,czorl,csots, + & csotl,cvwgs,cvetl,cvets,calfs, + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, + & calbl,calfl,calbs,ctsfs,grboro, + & grbmsk,ctsfl,deltf,caisl,caiss, + & fsalfl,fsalfs,flalfs,falbl,ftsfl, + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, + & deltsfc,critp2,critp3,blnmsk,critp1, + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 + &, fsihl,fsihs,fsicl,fsics, + & csihl,csihs,csicl,csics,epssih,epssic + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, + & epsslp,epsabs + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, + & siclmx,siclmn,sicomx,sicomn,sicsmx, + & sicsmn,sicimx,sicimn,sicjmx,sicjmn + &, glacir_hice + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, + & slplmx,slplmn,slpomx,slpomn,slpsmx, + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, + & abslmx,abslmn,absomx,absomn,abssmx, + & abssmn,absimx,absimn,absjmx,absjmn + &, sihnew + + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, + & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, + & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, + & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, + & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb + &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc + logical gausm, deads, qcmsk, znlst, monclm, monanl, + & monfcs, monmer, mondif, landice + character(len=*), intent(in) :: input_nml_file(sz_nml) + + integer num_parthds +! +!> this is a limited point version of surface program. +!! +!! this program runs in two different modes: +!! +!! 1. analysis mode (fh=0.) +!! +!! this program merges climatology, analysis and forecast guess to create +!! new surface fields. if analysis file is given, the program +!! uses it if date of the analysis matches with iy,im,id,ih (see note +!! below). +!! +!! 2. forecast mode (fh.gt.0.) +!! +!! this program interpolates climatology to the date corresponding to the +!! forecast hour. if surface analysis file is given, for the corresponding +!! dates, the program will use it. +!! +!! note: +!! +!! if the date of the analysis does not match given iy,im,id,ih, (and fh), +!! the program searches an old analysis by going back 6 hours, then 12 hours, +!! then one day upto nrepmx days (parameter statement in the subrotine fixrd. +!! now defined as 8). this allows the user to provide non-daily analysis to +!! be used. if matching field is not found, the forecast guess will be used. +!! +!! use of a combined earlier surface analyses and current analysis is +!! not allowed (as was done in the old version for snow analysis in which +!! old snow analysis is used in combination with initial guess), except +!! for sea surface temperature. for sst anolmaly interpolation, you need to +!! set lanom=.true. and must provide sst analysis at initial time. +!! +!! if you want to do complex merging of past and present surface field analysis, +!! you need to create a separate file that contains daily surface field. +!! +!! for a dead start, do not supply fnbgsi or set fnbgsi=' ' +! +! lugb is the unit number used in this subprogram +! len ... number of points on which sfccyc operates +! lsoil .. number of soil layers (2 as of april, 1994) +! iy,im,id,ih .. year, month, day, and hour of initial state. +! fh .. forecast hour +! rla, rlo -- latitude and longitudes of the len points +! sig1t .. sigma level 1 temperature for dead start. should be on gaussian +! grid. if not dead start, no need for dimension but set to zero +! as in the example below. +! +! variable naming conventions: +! +! oro .. orography +! alb .. albedo +! wet .. soil wetness as defined for bucket model +! sno .. snow depth +! zor .. surface roughness length +! vet .. vegetation type +! plr .. plant evaporation resistance +! tsf .. surface skin temperature. sea surface temp. over ocean. +! tg3 .. deep soil temperature (at 500cm) +! stc .. soil temperature (lsoil layrs) +! smc .. soil moisture (lsoil layrs) +! scv .. snow cover (not snow depth) +! ais .. sea ice mask (0 or 1) +! acn .. sea ice concentration (fraction) +! gla .. glacier (permanent snow) mask (0 or 1) +! mxi .. maximum sea ice extent (0 or 1) +! msk .. land ocean mask (0=ocean 1=land) +! cnp .. canopy water content +! cv .. convective cloud cover +! cvb .. convective cloud base +! cvt .. convective cloud top +! sli .. land/sea/sea-ice mask. (1/0/2 respectively) +! veg .. vegetation cover +! sot .. soil type +!cwu [+2l] add sih & sic +! sih .. sea ice thickness +! sic .. sea ice concentration +!clu [+6l] add swd,slc,vmn,vmx,slp,abs +! swd .. actual snow depth +! slc .. liquid soil moisture (lsoil layers) +! vmn .. vegetation cover minimum +! vmx .. vegetation cover maximum +! slp .. slope type +! abs .. maximum snow albedo + +! +! definition of land/sea mask. sllnd for land and slsea for sea. +! definition of sea/ice mask. aicice for ice, aicsea for sea. +! tgice=max ice temperature +! rlapse=lapse rate for sst correction due to surface angulation +! + parameter(sllnd =1.0,slsea =0.0) + parameter(aicice=1.0,aicsea=0.0) + parameter(tgice=271.2) + parameter(rlapse=0.65e-2) +! +! max/min of fields for check and replace. +! +! ???lmx .. max over bare land +! ???lmn .. min over bare land +! ???omx .. max over open ocean +! ???omn .. min over open ocean +! ???smx .. max over snow surface (land and sea-ice) +! ???smn .. min over snow surface (land and sea-ice) +! ???imx .. max over bare sea ice +! ???imn .. min over bare sea ice +! ???jmx .. max over snow covered sea ice +! ???jmn .. min over snow covered sea ice +! + parameter(orolmx=8000.,orolmn=-1000.,oroomx=3000.,oroomn=-1000., + & orosmx=8000.,orosmn=-1000.,oroimx=3000.,oroimn=-1000., + & orojmx=3000.,orojmn=-1000.) +! parameter(alblmx=0.80,alblmn=0.06,albomx=0.06,albomn=0.06, +! & albsmx=0.80,albsmn=0.06,albimx=0.80,albimn=0.80, +! & albjmx=0.80,albjmn=0.80) +!cwu [-3l/+9l] change min/max for alb; add min/max for sih & sic +! parameter(alblmx=0.80,alblmn=0.01,albomx=0.01,albomn=0.01, +! & albsmx=0.80,albsmn=0.01,albimx=0.01,albimn=0.01, +! & albjmx=0.01,albjmn=0.01) +! note: the range values for bare land and snow covered land +! (alblmx, alblmn, albsmx, albsmn) are set below +! based on whether the old or new radiation is selected + parameter(albomx=0.06,albomn=0.06, + & albimx=0.80,albimn=0.06, + & albjmx=0.80,albjmn=0.06) + parameter(sihlmx=0.0,sihlmn=0.0,sihomx=5.0,sihomn=0.0, + & sihsmx=5.0,sihsmn=0.0,sihimx=5.0,sihimn=0.10, + & sihjmx=5.0,sihjmn=0.10,glacir_hice=3.0) +!cwu change sicimn & sicjmn Jan 2015 +! parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, +! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.50, +! & sicjmx=1.0,sicjmn=0.50) +! +! parameter(sihlmx=0.0,sihlmn=0.0,sihomx=8.0,sihomn=0.0, +! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, +! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) + parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, + & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, + & sicjmx=1.0,sicjmn=0.15) + + parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, + & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, + & wetjmx=0.15,wetjmn=0.15) + parameter(snolmx=0.0,snolmn=0.0,snoomx=0.0,snoomn=0.0, + & snosmx=55000.,snosmn=0.001,snoimx=0.,snoimn=0.0, + & snojmx=10000.,snojmn=0.01) + parameter(zorlmx=300.,zorlmn=1.0,zoromx=1.0,zoromn=1.e-05, + & zorsmx=300.,zorsmn=1.0,zorimx=1.0,zorimn=1.0, + & zorjmx=1.0,zorjmn=1.0) + parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, + & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, + & plrjmx=1000.,plrjmn=0.0) +!clu [-1l/+1l] relax tsfsmx (for noah lsm) + parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, + & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, + & tsfjmx=273.16,tsfjmn=173.0) +! parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.21, +!* & tsfsmx=273.16,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, +! & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, + parameter(tg3lmx=310.,tg3lmn=200.0,tg3omx=310.0,tg3omn=200.0, + & tg3smx=310.,tg3smn=200.0,tg3imx=310.0,tg3imn=200.0, + & tg3jmx=310.,tg3jmn=200.0) + parameter(stclmx=353.,stclmn=173.0,stcomx=313.0,stcomn=200.0, + & stcsmx=310.,stcsmn=200.0,stcimx=310.0,stcimn=200.0, + & stcjmx=310.,stcjmn=200.0) +!landice mods force a flag value of soil moisture of 1.0 +! at non-land points + parameter(smclmx=0.55,smclmn=0.0,smcomx=1.0,smcomn=1.0, + & smcsmx=0.55,smcsmn=0.0,smcimx=1.0,smcimn=1.0, + & smcjmx=1.0,smcjmn=1.0) + parameter(scvlmx=0.0,scvlmn=0.0,scvomx=0.0,scvomn=0.0, + & scvsmx=1.0,scvsmn=1.0,scvimx=0.0,scvimn=0.0, + & scvjmx=1.0,scvjmn=1.0) + parameter(veglmx=1.0,veglmn=0.0,vegomx=0.0,vegomn=0.0, + & vegsmx=1.0,vegsmn=0.0,vegimx=0.0,vegimn=0.0, + & vegjmx=0.0,vegjmn=0.0) + parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, + & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, + & vmnjmx=0.0,vmnjmn=0.0) + parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, + & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, + & vmxjmx=0.0,vmxjmn=0.0) + parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, + & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., + & slpjmx=0.,slpjmn=0.) +! note: the range values for bare land and snow covered land +! (alblmx, alblmn, albsmx, albsmn) are set below +! based on whether the old or new radiation is selected + parameter(absomx=0.0,absomn=0.0, + & absimx=0.0,absimn=0.0, + & absjmx=0.0,absjmn=0.0) +! vegetation type + parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, + & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., + & vetjmx=0.,vetjmn=0.) +! soil type + parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0, + & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0., + & sotjmx=0.,sotjmn=0.) +! fraction of vegetation for strongly and weakly zeneith angle dependent +! albedo + parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0, + & alssmx=1.0,alssmn=0.0,alsimx=0.0,alsimn=0.0, + & alsjmx=0.0,alsjmn=0.0) +! +! criteria used for monitoring +! + parameter(epstsf=0.01,epsalb=0.001,epssno=0.01, + & epswet=0.01,epszor=0.0000001,epsplr=1.,epsoro=0., + & epssmc=0.0001,epsscv=0.,eptsfc=0.01,epstg3=0.01, + & epsais=0.,epsacn=0.01,epsveg=0.01, + & epssih=0.001,epssic=0.001, + & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01, + & epsvet=.01,epssot=.01,epsalf=.001) +! +! quality control of analysis snow and sea ice +! +! qctsfs .. surface temperature above which no snow allowed +! qcsnos .. snow depth above which snow must exist +! qctsfi .. sst above which sea-ice is not allowed +! +!clu relax qctsfs (for noah lsm) +!* parameter(qctsfs=283.16,qcsnos=100.,qctsfi=280.16) +!* parameter(qctsfs=288.16,qcsnos=100.,qctsfi=280.16) + parameter(qctsfs=293.16,qcsnos=100.,qctsfi=280.16) +! +!cwu [-2l] +!* ice concentration for ice limit (55 percent) +! +!* parameter(aislim=0.55) +! +! parameters to obtain snow depth from snow cover and temperature +! +! parameter(snwmin=25.,snwmax=100.) + parameter(snwmin=5.0,snwmax=100.) + real (kind=kind_io8), parameter :: ten=10.0, one=1.0 +! +! coeeficients of blending forecast and interpolated clim +! (or analyzed) fields over sea or land(l) (not for clouds) +! 1.0 = use of forecast +! 0.0 = replace with interpolated analysis +! +! these values are set for analysis mode. +! +! variables land sea +! --------------------------------------------------------- +! surface temperature forecast analysis +! surface temperature forecast forecast (over sea ice) +! albedo analysis analysis +! sea-ice analysis analysis +! snow analysis forecast (over sea ice) +! roughness analysis forecast +! plant resistance analysis analysis +! soil wetness (layer) weighted average analysis +! soil temperature forecast analysis +! canopy waver content forecast forecast +! convective cloud cover forecast forecast +! convective cloud bottm forecast forecast +! convective cloud top forecast forecast +! vegetation cover analysis analysis +! vegetation type analysis analysis +! soil type analysis analysis +! sea-ice thickness forecast forecast +! sea-ice concentration analysis analysis +! vegetation cover min analysis analysis +! vegetation cover max analysis analysis +! max snow albedo analysis analysis +! slope type analysis analysis +! liquid soil wetness analysis-weighted analysis +! actual snow depth analysis-weighted analysis +! +! note: if analysis file is not given, then time interpolated climatology +! is used. if analyiss file is given, it will be used as far as the +! date and time matches. if they do not match, it uses forecast. +! +! critical percentage value for aborting bad points when lgchek=.true. +! + logical lgchek + data lgchek/.true./ + data critp1,critp2,critp3/80.,80.,25./ +! +! integer kpdalb(4), kpdalf(2) +! data kpdalb/212,215,213,216/, kpdalf/214,217/ +! save kpdalb, kpdalf +! +! mask orography and variance on gaussian grid +! + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) + &, orogd(len) + real (kind=kind_io8) rla(len), rlo(len) +! +! permanent/extremes +! + character*500 fnglac,fnmxic + real (kind=kind_io8), allocatable :: glacir(:),amxice(:),tsfcl0(:) +! +! tsfcl0 is the climatological tsf at fh=0 +! +! climatology surface fields (last character 'c' or 'clm' indicate climatology) +! + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, + & fnvegc,fnvetc,fnsotc + &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), + & zorclm(len), albclm(len,4), aisclm(len), + & tg3clm(len), acnclm(len), cnpclm(len), + & cvclm (len), cvbclm(len), cvtclm(len), + & scvclm(len), tsfcl2(len), vegclm(len), + & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), + & smcclm(len,lsoil), stcclm(len,lsoil) + &, sihclm(len), sicclm(len) + &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) +! +! analyzed surface fields (last character 'a' or 'anl' indicate analysis) +! + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, + & fnvega,fnveta,fnsota + &, fnvmna,fnvmxa,fnslpa,fnabsa +! + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), cnpanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & scvanl(len), tsfan2(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), + & smcanl(len,lsoil), stcanl(len,lsoil) + &, sihanl(len), sicanl(len) + &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) +! + real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. +! +! predicted surface fields (last characters 'fcs' indicates forecast) +! + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & tg3fcs(len), acnfcs(len), cnpfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2), + & smcfcs(len,lsoil), stcfcs(len,lsoil) + &, sihfcs(len), sicfcs(len), sitfcs(len) + &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) + &, swdfcs(len), slcfcs(len,lsoil) +! +! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched +! in this program). +! + real (kind=kind_io8) f10m (len) + real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) + real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) + +!clu [+1l] add swratio (soil moisture liquid-to-total ratio) + real (kind=kind_io8) swratio(len,lsoil) +!clu [+1l] add fixratio (option to adjust slc from smc) + logical fixratio(lsoil) +! + integer icsmcl(25), icsmcs(25), icstcl(25), icstcs(25) +! + real (kind=kind_io8) csmcl(25), csmcs(25) + real (kind=kind_io8) cstcl(25), cstcs(25) +! + real (kind=kind_io8) slmskh(mdata) + character*500 fnmskh + integer kpd7, kpd9 +! + logical icefl1(len), icefl2(len) +! +! input and output surface fields (bges) file names +! +! +! sigma level 1 temperature for dead start +! + real (kind=kind_io8) sig1t(len) +! + character*32 label +! +! = 1 ==> forecast is used +! = 0 ==> analysis (or climatology) is used +! +! output file ... primary surface file for radiation and forecast +! +! rec. 1 label +! rec. 2 date record +! rec. 3 tsf +! rec. 4 soilm(two layers) ----> 4 layers +! rec. 5 snow +! rec. 6 soilt(two layers) ----> 4 layers +! rec. 7 tg3 +! rec. 8 zor +! rec. 9 cv +! rec. 10 cvb +! rec. 11 cvt +! rec. 12 albedo (four types) +! rec. 13 slimsk +! rec. 14 vegetation cover +! rec. 14 plantr -----> skip this record +! rec. 15 f10m -----> canopy +! rec. 16 canopy water content (cnpanl) -----> f10m +! rec. 17 vegetation type +! rec. 18 soil type +! rec. 19 zeneith angle dependent vegetation fraction (two types) +! rec. 20 uustar +! rec. 21 ffmm +! rec. 22 ffhh +!cwu add sih & sic +! rec. 23 sih(one category only) +! rec. 24 sic +!clu [+8l] add prcp, flag, swd, slc, vmn, vmx, slp, abs +! rec. 25 tprcp +! rec. 26 srflag +! rec. 27 swd +! rec. 28 slc (4 layers) +! rec. 29 vmn +! rec. 30 vmx +! rec. 31 slp +! rec. 32 abs + +! +! debug only +! ldebug=.true. creates bges files for climatology and analysis +! lqcbgs=.true. quality controls input bges file before merging (should have been +! qced in the forecast program) +! + logical ldebug,lqcbgs + logical lprnt +! +! debug only +! + character*500 fndclm,fndanl +! + logical lanom + +! + namelist/namsfc/fnglac,fnmxic, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, + & fnvegc,fnvetc,fnsotc,fnalbc2, + & fnvmnc,fnvmxc,fnslpc,fnabsc, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, + & fnvega,fnveta,fnsota, + & fnvmna,fnvmxa,fnslpa,fnabsa, + & fnmskh, + & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, + & fndclm,fndanl, + & lanom, + & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, + & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs, + & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, + & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, + & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs, + & fsihl,fsicl,fsihs,fsics,aislim,sihnew, + & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss, + & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, + & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, + & icstcl,icstcs,icalfl,icalfs, + & gausm, deads, qcmsk, znlst, + & monclm, monanl, monfcs, monmer, mondif, igrdbg, + & blnmsk, bltmsk, landice +! + data gausm/.true./, deads/.false./, blnmsk/0.0/, bltmsk/90.0/ + &, qcmsk/.false./, znlst/.false./, igrdbg/-1/ + &, monclm/.false./, monanl/.false./, monfcs/.false./ + &, monmer/.false./, mondif/.false./, landice/.true./ +! +! defaults file names +! + data fnmskh/'global_slmask.t126.grb'/ + data fnalbc/'global_albedo4.1x1.grb'/ + data fnalbc2/'global_albedo4.1x1.grb'/ + data fntsfc/'global_sstclim.2x2.grb'/ + data fnsotc/'global_soiltype.1x1.grb'/ + data fnvegc/'global_vegfrac.1x1.grb'/ + data fnvetc/'global_vegtype.1x1.grb'/ + data fnglac/'global_glacier.2x2.grb'/ + data fnmxic/'global_maxice.2x2.grb'/ + data fnsnoc/'global_snoclim.1.875.grb'/ + data fnzorc/'global_zorclim.1x1.grb'/ + data fnaisc/'global_iceclim.2x2.grb'/ + data fntg3c/'global_tg3clim.2.6x1.5.grb'/ + data fnsmcc/'global_soilmcpc.1x1.grb'/ +!clu [+4l] add fn()c for vmn, vmx, abs, slp + data fnvmnc/'global_shdmin.0.144x0.144.grb'/ + data fnvmxc/'global_shdmax.0.144x0.144.grb'/ + data fnslpc/'global_slope.1x1.grb'/ + data fnabsc/'global_snoalb.1x1.grb'/ +! + data fnwetc/' '/ + data fnplrc/' '/ + data fnstcc/' '/ + data fnscvc/' '/ + data fnacnc/' '/ +! + data fntsfa/' '/ + data fnweta/' '/ + data fnsnoa/' '/ + data fnzora/' '/ + data fnalba/' '/ + data fnaisa/' '/ + data fnplra/' '/ + data fntg3a/' '/ + data fnsmca/' '/ + data fnstca/' '/ + data fnscva/' '/ + data fnacna/' '/ + data fnvega/' '/ + data fnveta/' '/ + data fnsota/' '/ +!clu [+4l] add fn()a for vmn, vmx, abs, slp + data fnvmna/' '/ + data fnvmxa/' '/ + data fnslpa/' '/ + data fnabsa/' '/ +! + data ldebug/.false./, lqcbgs/.true./ + data fndclm/' '/ + data fndanl/' '/ + data lanom/.false./ +! +! default relaxation time in hours to analysis or climatology + data ftsfl/99999.0/, ftsfs/0.0/ + data falbl/0.0/, falbs/0.0/ + data falfl/0.0/, falfs/0.0/ + data faisl/0.0/, faiss/0.0/ + data fsnol/0.0/, fsnos/99999.0/ + data fzorl/0.0/, fzors/99999.0/ + data fplrl/0.0/, fplrs/0.0/ + data fvetl/0.0/, fvets/99999.0/ + data fsotl/0.0/, fsots/99999.0/ + data fvegl/0.0/, fvegs/99999.0/ +!cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim + data fsihl/99999.0/, fsihs/99999.0/ +! data fsicl/99999.0/, fsics/99999.0/ + data fsicl/0.0/, fsics/0.0/ +! default ice concentration limit (50%), new ice thickness (20cm) +!cwu change ice concentration limit (15%) Jan 2015 +! data aislim/0.50/, sihnew/0.2/ + data aislim/0.15/, sihnew/0.2/ +!clu [+4l] add f()l and f()s for vmn, vmx, abs, slp + data fvmnl/0.0/, fvmns/99999.0/ + data fvmxl/0.0/, fvmxs/99999.0/ + data fslpl/0.0/, fslps/99999.0/ + data fabsl/0.0/, fabss/99999.0/ +! default relaxation time in hours to climatology if analysis missing + data fctsfl/99999.0/, fctsfs/99999.0/ + data fcalbl/99999.0/, fcalbs/99999.0/ + data fcsnol/99999.0/, fcsnos/99999.0/ + data fczorl/99999.0/, fczors/99999.0/ + data fcplrl/99999.0/, fcplrs/99999.0/ +! default flag to apply climatological annual cycle + data ictsfl/0/, ictsfs/1/ + data icalbl/1/, icalbs/1/ + data icalfl/1/, icalfs/1/ + data icsnol/0/, icsnos/0/ + data iczorl/1/, iczors/0/ + data icplrl/1/, icplrs/0/ +! + data ccnp/1.0/ + data ccv/1.0/, ccvb/1.0/, ccvt/1.0/ +! + data ifp/0/ +! + save ifp,fnglac,fnmxic, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnvetc,fnveta, + & fnsotc,fnsota, +!clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs + & fnvmnc,fnvmxc,fnabsc,fnslpc, + & fnvmna,fnvmxa,fnabsa,fnslpa, + & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, + & fndclm,fndanl, + & lanom, + & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, + & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs, + & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, + & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, + & fcstcl,fcstcs,fcalfl,fcalfs, +!cwu [+1l] add f()l and f()s for sih, sic and aislim, sihnew + & fsihl,fsihs,fsicl,fsics,aislim,sihnew, +!clu [+2l] add f()l and f()s for vmn, vmx, slp, abs + & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss, + & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, + & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, + & icstcl,icstcs,icalfl,icalfs, + & gausm, deads, qcmsk, + & monclm, monanl, monfcs, monmer, mondif, igrdbg, + & grboro, grbmsk, +! + & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs, + & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl, + & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots, + & csmcl +!cwu [+1l] add c()l and c()s for sih, sic + &, csihl, csihs, csicl, csics +!clu [+2l] add c()l and c()s for vmn, vmx, slp, abs + &, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps, + & cabsl, cabss + &, imsk, jmsk, slmskh, blnmsk, bltmsk + &, glacir, amxice, tsfcl0 + &, caisl, caiss, cvegs +! + lprnt = .false. + iprnt = 1 +! do i=1,len +! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) +! *,' rlo=',rlo(i) +! tem1 = abs(rla(i) - 48.75) +! tem2 = abs(rlo(i) - (-68.50)) +! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then +! lprnt = .true. +! iprnt = i +! print *,' lprnt=',lprnt,' iprnt=',iprnt +! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) +! endif +! enddo + if (ialb == 1) then + kpdabs = kpdabs_1 + kpdalb = kpdalb_1 + alblmx = .99 + albsmx = .99 + alblmn = .01 + albsmn = .01 + abslmx = 1.0 + abssmx = 1.0 + abssmn = .01 + abslmn = .01 + else + kpdabs = kpdabs_0 + kpdalb = kpdalb_0 + alblmx = .80 + albsmx = .80 + alblmn = .06 + albsmn = .06 + abslmx = .80 + abssmx = .80 + abslmn = .01 + abssmn = .01 + endif + if(ifp.eq.0) then + ifp = 1 + do k=1,lsoil + fsmcl(k) = 99999. + fsmcs(k) = 0. + fstcl(k) = 99999. + fstcs(k) = 0. + enddo +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=namsfc) +#else +! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb + rewind(nlunit) + read (nlunit,namsfc) +#endif +! write(6,namsfc) +! + if (me .eq. 0) then + print *,'ftsfl,falbl,faisl,fsnol,fzorl=', + & ftsfl,falbl,faisl,fsnol,fzorl + print *,'fsmcl=',fsmcl(1:lsoil) + print *,'fstcl=',fstcl(1:lsoil) + print *,'ftsfs,falbs,faiss,fsnos,fzors=', + & ftsfs,falbs,faiss,fsnos,fzors + print *,'fsmcs=',fsmcs(1:lsoil) + print *,'fstcs=',fstcs(1:lsoil) + print *,' aislim=',aislim,' sihnew=',sihnew + print *,' isot=', isot,' ivegsrc=',ivegsrc + endif + + if (ivegsrc == 2) then ! sib + veg_type_landice=13 + else + veg_type_landice=15 + endif + if (isot == 0) then + soil_type_landice=9 + else + soil_type_landice=16 + endif +! + deltf = deltsfc / 24.0 +! + ctsfl=0. !... tsfc over land + if(ftsfl.ge.99999.) ctsfl=1. + if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) +! + ctsfs=0. !... tsfc over sea + if(ftsfs.ge.99999.) ctsfs=1. + if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) +! + do k=1,lsoil + csmcl(k)=0. !... soilm over land + if(fsmcl(k).ge.99999.) csmcl(k)=1. + if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) + & csmcl(k)=exp(-deltf/fsmcl(k)) + csmcs(k)=0. !... soilm over sea + if(fsmcs(k).ge.99999.) csmcs(k)=1. + if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) + & csmcs(k)=exp(-deltf/fsmcs(k)) + enddo +! + calbl=0. !... albedo over land + if(falbl.ge.99999.) calbl=1. + if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) +! + calfl=0. !... fraction field for albedo over land + if(falfl.ge.99999.) calfl=1. + if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) +! + calbs=0. !... albedo over sea + if(falbs.ge.99999.) calbs=1. + if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) +! + calfs=0. !... fraction field for albedo over sea + if(falfs.ge.99999.) calfs=1. + if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) +! + caisl=0. !... sea ice over land + if(faisl.ge.99999.) caisl=1. + if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. +! + caiss=0. !... sea ice over sea + if(faiss.ge.99999.) caiss=1. + if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. +! + csnol=0. !... snow over land + if(fsnol.ge.99999.) csnol=1. + if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) +! using the same way to bending snow as narr when fsnol is the negative value +! the magnitude of fsnol is the thread to determine the lower and upper bound +! of final swe + if(fsnol.lt.0.)csnol=fsnol +! + csnos=0. !... snow over sea + if(fsnos.ge.99999.) csnos=1. + if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) +! + czorl=0. !... roughness length over land + if(fzorl.ge.99999.) czorl=1. + if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) +! + czors=0. !... roughness length over sea + if(fzors.ge.99999.) czors=1. + if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) +! +! cplrl=0. !... plant resistance over land +! if(fplrl.ge.99999.) cplrl=1. +! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) +! +! cplrs=0. !... plant resistance over sea +! if(fplrs.ge.99999.) cplrs=1. +! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) +! + do k=1,lsoil + cstcl(k)=0. !... soilt over land + if(fstcl(k).ge.99999.) cstcl(k)=1. + if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) + & cstcl(k)=exp(-deltf/fstcl(k)) + cstcs(k)=0. !... soilt over sea + if(fstcs(k).ge.99999.) cstcs(k)=1. + if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) + & cstcs(k)=exp(-deltf/fstcs(k)) + enddo +! + cvegl=0. !... vegetation fraction over land + if(fvegl.ge.99999.) cvegl=1. + if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) +! + cvegs=0. !... vegetation fraction over sea + if(fvegs.ge.99999.) cvegs=1. + if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) +! + cvetl=0. !... vegetation type over land + if(fvetl.ge.99999.) cvetl=1. + if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) +! + cvets=0. !... vegetation type over sea + if(fvets.ge.99999.) cvets=1. + if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) +! + csotl=0. !... soil type over land + if(fsotl.ge.99999.) csotl=1. + if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) +! + csots=0. !... soil type over sea + if(fsots.ge.99999.) csots=1. + if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) + +!cwu [+16l]--------------------------------------------------------------- +! + csihl=0. !... sea ice thickness over land + if(fsihl.ge.99999.) csihl=1. + if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) +! + csihs=0. !... sea ice thickness over sea + if(fsihs.ge.99999.) csihs=1. + if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) +! + csicl=0. !... sea ice concentration over land + if(fsicl.ge.99999.) csicl=1. + if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) +! + csics=0. !... sea ice concentration over sea + if(fsics.ge.99999.) csics=1. + if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) + +!clu [+32l]--------------------------------------------------------------- +! + cvmnl=0. !... min veg cover over land + if(fvmnl.ge.99999.) cvmnl=1. + if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) +! + cvmns=0. !... min veg cover over sea + if(fvmns.ge.99999.) cvmns=1. + if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) +! + cvmxl=0. !... max veg cover over land + if(fvmxl.ge.99999.) cvmxl=1. + if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) +! + cvmxs=0. !... max veg cover over sea + if(fvmxs.ge.99999.) cvmxs=1. + if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) +! + cslpl=0. !... slope type over land + if(fslpl.ge.99999.) cslpl=1. + if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) +! + cslps=0. !... slope type over sea + if(fslps.ge.99999.) cslps=1. + if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) +! + cabsl=0. !... snow albedo over land + if(fabsl.ge.99999.) cabsl=1. + if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) +! + cabss=0. !... snow albedo over sea + if(fabss.ge.99999.) cabss=1. + if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) +!clu ---------------------------------------------------------------------- +! +! read a high resolution mask field for use in grib interpolation +! + call hmskrd(lugb,imsk,jmsk,fnmskh, + & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) +! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) +! + if (me .eq. 0) then + write(6,*) ' ' + write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil + write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh + &, ' sig1t(1)=',sig1t(1) + &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk + write(6,*) ' ' + endif +! +! reading permanent/extreme features (glacier points and maximum ice extent) +! + allocate (tsfcl0(len)) + allocate (glacir(len)) + allocate (amxice(len)) +! +! read glacier +! + kpd9 = -1 + kpd7 = -1 + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, + & glacir,len,iret + &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk + &, rla, rlo, me) +! znnt=1. +! call nntprt(glacir,len,znnt) +! +! read maximum ice extent +! + kpd7 = -1 + call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, + & amxice,len,iret + &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk + &, rla, rlo, me) +! znnt=1. +! call nntprt(amxice,len,znnt) +! + crit=0.5 + call rof01(glacir,len,'ge',crit) + call rof01(amxice,len,'ge',crit) +! +! quality control max ice limit based on glacier points +! + call qcmxice(glacir,amxice,len,me) +! + endif ! first time loop finished +! + do i=1,len + sliclm(i) = 1. + snoclm(i) = 0. + icefl1(i) = .true. + enddo +! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) +! +! read climatology fields +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) 'climatology' + write(6,*) '==============' + endif +! + percrit=critp1 +! + call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc, + & fnvmnc,fnvmxc,fnslpc,fnabsc, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, + & vetclm,sotclm,alfclm, + & vmnclm,vmxclm,slpclm,absclm, + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & deltsfc, lanom + &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me + &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) +! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) +! +! scale surface roughness and albedo to model required units +! + zsca=100. + call scale(zorclm,len,zsca) + zsca=0.01 + call scale(albclm,len,zsca) + call scale(albclm(1,2),len,zsca) + call scale(albclm(1,3),len,zsca) + call scale(albclm(1,4),len,zsca) + call scale(alfclm,len,zsca) + call scale(alfclm(1,2),len,zsca) +!clu [+4l] scale vmn, vmx, abs from percent to fraction + zsca=0.01 + call scale(vmnclm,len,zsca) + call scale(vmxclm,len,zsca) + call scale(absclm,len,zsca) + +! +! set albedo over ocean to albomx +! + call albocn(albclm,slmask,albomx,len) +! +! make sure vegetation type and soil type are non zero over land +! + call landtyp(vetclm,sotclm,slpclm,slmask,len) +! +!cwu [-1l/+1l] +!* ice concentration or ice mask (only ice mask used in the model now) +! ice concentration and ice mask (both are used in the model now) +! + if(fnaisc(1:8).ne.' ') then +!cwu [+5l/-1l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*aisclm(i) + sicclm(i) = aisclm(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim +!* crit=0.5 + call rof01(aisclm,len,'ge',crit) + elseif(fnacnc(1:8).ne.' ') then +!cwu [+4l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*acnclm(i) + sicclm(i) = acnclm(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + call rof01(acnclm,len,'ge',aislim) + do i=1,len + aisclm(i) = acnclm(i) + enddo + endif +! +! quality control of sea ice mask +! + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmask,aisclm,len,aicice,sliclm) +! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' +! *,sliclm(iprnt),' slmask=',slmask(iprnt) +! +! write(6,*) 'sliclm' +! znnt=1. +! call nntprt(sliclm,len,znnt) +! +! quality control of snow +! + call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) +! + call setzro(snoclm,epssno,len) +! +! snow cover handling (we assume climatological snow depth is available) +! quality control of snow depth (note that snow should be corrected first +! because it influences tsf +! + kqcm=1 + call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! write(6,*) 'snoclm' +! znnt=1. +! call nntprt(snoclm,len,znnt) +! +! get snow cover from snow depth array +! + if(fnscvc(1:8).eq.' ') then + call getscv(snoclm,scvclm,len) + endif +! +! set tsfc over snow to tsfsmx if greater +! + call snosfc(snoclm,tsfclm,tsfsmx,len,me) +! call snosfc(snoclm,tsfcl2,tsfsmx,len) + +! +! quality control +! + do i=1,len + icefl2(i) = sicclm(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsf2 ',tsfcl2,sliclm,snoclm,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albc ',albclm(1,kk),sliclm,snoclm,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ') then + call qcmxmn('wetc ',wetclm,sliclm,snoclm,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorc ',zorclm,sliclm,snoclm,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ') then +! call qcmxmn('plntc ',plrclm,sliclm,snoclm,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3c ',tg3clm,sliclm,snoclm,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! get soil temp and moisture (after all the qcs are completed) +! + if(fnsmcc(1:8).eq.' ') then + call getsmc(wetclm,len,lsoil,smcclm,me) + endif + call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcclm(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + if(fnstcc(1:8).eq.' ') then + call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) + endif + call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcclm(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetc ',vetclm,sliclm,snoclm,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotc ',sotclm,sliclm,snoclm,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] --------------------------------------------------------------- + call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l] --------------------------------------------------------------- + call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxc ',vmxclm,sliclm,snoclm,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpc ',slpclm,sliclm,snoclm,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absc ',absclm,sliclm,snoclm,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ---------------------------------------------------------------------- +! +! monitoring prints +! + if (monclm) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of time and space interpolated climatology' + print *,' ' +! call count(sliclm,snoclm,len) + print *,' ' + call monitr('tsfclm',tsfclm,sliclm,snoclm,len) + call monitr('albclm',albclm(1,1),sliclm,snoclm,len) + call monitr('albclm',albclm(1,2),sliclm,snoclm,len) + call monitr('albclm',albclm(1,3),sliclm,snoclm,len) + call monitr('albclm',albclm(1,4),sliclm,snoclm,len) + call monitr('aisclm',aisclm,sliclm,snoclm,len) + call monitr('snoclm',snoclm,sliclm,snoclm,len) + call monitr('scvclm',scvclm,sliclm,snoclm,len) + call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) + call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) + call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) + call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) +!clu [+4l] add smcclm(3:4) and stcclm(3:4) + if(lsoil.gt.2) then + call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) + call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) + call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) + call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) + endif + call monitr('tg3clm',tg3clm,sliclm,snoclm,len) + call monitr('zorclm',zorclm,sliclm,snoclm,len) +! if (gaus) then + call monitr('cvaclm',cvclm ,sliclm,snoclm,len) + call monitr('cvbclm',cvbclm,sliclm,snoclm,len) + call monitr('cvtclm',cvtclm,sliclm,snoclm,len) +! endif + call monitr('sliclm',sliclm,sliclm,snoclm,len) +! call monitr('plrclm',plrclm,sliclm,snoclm,len) + call monitr('orog ',orog ,sliclm,snoclm,len) + call monitr('vegclm',vegclm,sliclm,snoclm,len) + call monitr('vetclm',vetclm,sliclm,snoclm,len) + call monitr('sotclm',sotclm,sliclm,snoclm,len) +!cwu [+2l] add sih, sic + call monitr('sihclm',sihclm,sliclm,snoclm,len) + call monitr('sicclm',sicclm,sliclm,snoclm,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnclm',vmnclm,sliclm,snoclm,len) + call monitr('vmxclm',vmxclm,sliclm,snoclm,len) + call monitr('slpclm',slpclm,sliclm,snoclm,len) + call monitr('absclm',absclm,sliclm,snoclm,len) + endif + endif +! +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) ' analysis' + write(6,*) '==============' + endif +! +! fill in analysis array with climatology before reading analysis. +! + call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, + & vetanl,sotanl,alfanl, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, + & vetclm,sotclm,alfclm, + & sihclm,sicclm, + & vmnclm,vmxclm,slpclm,absclm, + & len,lsoil) +! +! reverse scaling to match with grib analysis input +! + zsca=0.01 + call scale(zoranl,len, zsca) + zsca=100. + call scale(albanl,len,zsca) + call scale(albanl(1,2),len,zsca) + call scale(albanl(1,3),len,zsca) + call scale(albanl(1,4),len,zsca) + call scale(alfanl,len,zsca) + call scale(alfanl(1,2),len,zsca) +!clu [+4l] reverse scale for vmn, vmx, abs + zsca=100. + call scale(vmnanl,len,zsca) + call scale(vmxanl,len,zsca) + call scale(absanl,len,zsca) +! + percrit=critp2 +! +! read analysis fields +! + call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota, + & fnvmna,fnvmxa,fnslpa,fnabsa, + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, + & vetanl,sotanl,alfanl,tsfan0, + & vmnanl,vmxanl,slpanl,absanl, + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf, + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvet,irtsot,irtalf + &, irtvmn,irtvmx,irtslp,irtabs, + & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk + &, me, lanom) +! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) +! +! scale zor and alb to match forecast model units +! + zsca=100. + call scale(zoranl,len, zsca) + zsca=0.01 + call scale(albanl,len,zsca) + call scale(albanl(1,2),len,zsca) + call scale(albanl(1,3),len,zsca) + call scale(albanl(1,4),len,zsca) + call scale(alfanl,len,zsca) + call scale(alfanl(1,2),len,zsca) +!clu [+4] scale vmn, vmx, abs from percent to fraction + zsca=0.01 + call scale(vmnanl,len,zsca) + call scale(vmxanl,len,zsca) + call scale(absanl,len,zsca) +! +! interpolate climatology but fixing initial anomaly +! + if(fh > 0.0 .and. fntsfa(1:8) /= ' ' .and. lanom) then + call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) + endif +! +! if the tsfanl is at sea level, then bring it to the surface using +! unfiltered orography (for lakes). if the analysis is at lake surface +! as in the nst model, then this call should be removed - moorthi 09/23/2011 +! + if (use_ufo .and. .not. nst_anl) then + ztsfc = 0.0 + call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) + endif +! +! ice concentration or ice mask (only ice mask used in the model now) +! + if(fnaisa(1:8).ne.' ') then +!cwu [+5l/-1l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*aisanl(i) + sicanl(i) = aisanl(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim +!* crit=0.5 + call rof01(aisanl,len,'ge',crit) + elseif(fnacna(1:8).ne.' ') then +!cwu [+17l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*acnanl(i) + sicanl(i) = acnanl(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim + do i=1,len + if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then + slianl(i)=2. +! print *,'cycle - new ice form: fice=',sicanl(i) + else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then + slianl(i)=0. +! print *,'cycle - ice free: fice=',sicanl(i) + else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i)=0. + endif + enddo +! znnt=10. +! call nntprt(acnanl,len,znnt) +! if(lprnt) print *,' acnanl=',acnanl(iprnt) +! do i=1,len +! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0 +! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim +! enddo +! if(lprnt) print *,' acnanl=',acnanl(iprnt) + call rof01(acnanl,len,'ge',aislim) + do i=1,len + aisanl(i)=acnanl(i) + enddo + endif +! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' +! &,glacir(iprnt),' slmask=',slmask(iprnt) +! + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmask,aisanl,len,aicice,slianl) +! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' +! *,slianl(iprnt),' slmask=',slmask(iprnt) +! +! + do k=1,lsoil + do i=1,len + if (slianl(i) .eq. 0) then + smcanl(i,k) = smcomx + stcanl(i,k) = tsfanl(i) + endif + enddo + enddo + +! write(6,*) 'slianl' +! znnt=1. +! call nntprt(slianl,len,znnt) +!cwu [+8l]---------------------------------------------------------------------- + call qcmxmn('siha ',sihanl,slianl,snoanl,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! set albedo over ocean to albomx +! + call albocn(albanl,slmask,albomx,len) +! +! quality control of snow and sea-ice +! process snow depth or snow cover +! + if(fnsnoa(1:8).ne.' ') then + call setzro(snoanl,epssno,len) + call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) + if (.not.landice) then + call snodpth2(glacir,snosmx,snoanl, len, me) + endif + kqcm=1 + call snosfc(snoanl,tsfanl,tsfsmx,len,me) + call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call getscv(snoanl,scvanl,len) + call qcmxmn('sncva ',scvanl,slianl,snoanl,icefl1, + & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, + & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, + & rla,rlo,len,kqcm,percrit,lgchek,me) + else + crit=0.5 + call rof01(scvanl,len,'ge',crit) + call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) + call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, + & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, + & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call snodpth(scvanl,slianl,tsfanl,snoclm, + & glacir,snwmax,snwmin,landice,len,snoanl,me) + call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) + call snosfc(snoanl,tsfanl,tsfsmx,len,me) + call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif +! + do i=1,len + icefl2(i) = sicanl(i) .gt. 0.99999 + enddo + call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('alba ',albanl(1,kk),slianl,snoanl,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then + call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zora ',zoranl,slianl,snoanl,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) then +! call qcmxmn('plna ',plranl,slianl,snoanl,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3a ',tg3anl,slianl,snoanl,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! get soil temp and moisture +! + if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then + call getsmc(wetanl,len,lsoil,smcanl,me) + endif + call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + if(fnstca(1:8).eq.' ') then + call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) + endif + call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('veta ',vetanl,slianl,snoanl,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sota ',sotanl,slianl,snoanl,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l]---------------------------------------------------------------------- + call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxa ',vmxanl,slianl,snoanl,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpa ',slpanl,slianl,snoanl,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absa ',absanl,slianl,snoanl,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ---------------------------------------------------------------------------- +! +! monitoring prints +! + if (monanl) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of time and space interpolated analysis' + print *,' ' +! call count(slianl,snoanl,len) + print *,' ' + call monitr('tsfanl',tsfanl,slianl,snoanl,len) + call monitr('albanl',albanl,slianl,snoanl,len) + call monitr('aisanl',aisanl,slianl,snoanl,len) + call monitr('snoanl',snoanl,slianl,snoanl,len) + call monitr('scvanl',scvanl,slianl,snoanl,len) + call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) +!clu [+4l] add smcanl(3:4) and stcanl(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + endif + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) +! if (gaus) then + call monitr('cvaanl',cvanl ,slianl,snoanl,len) + call monitr('cvbanl',cvbanl,slianl,snoanl,len) + call monitr('cvtanl',cvtanl,slianl,snoanl,len) +! endif + call monitr('slianl',slianl,slianl,snoanl,len) +! call monitr('plranl',plranl,slianl,snoanl,len) + call monitr('orog ',orog ,slianl,snoanl,len) + call monitr('veganl',veganl,slianl,snoanl,len) + call monitr('vetanl',vetanl,slianl,snoanl,len) + call monitr('sotanl',sotanl,slianl,snoanl,len) +!cwu [+2l] add sih, sic + call monitr('sihanl',sihanl,slianl,snoanl,len) + call monitr('sicanl',sicanl,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnanl',vmnanl,slianl,snoanl,len) + call monitr('vmxanl',vmxanl,slianl,snoanl,len) + call monitr('slpanl',slpanl,slianl,snoanl,len) + call monitr('absanl',absanl,slianl,snoanl,len) + endif + + endif +! +! read in forecast fields if needed +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) ' fcst guess' + write(6,*) '==============' + endif +! + percrit=critp2 +! + if(deads) then +! +! fill in guess array with analysis if dead start. +! + percrit=critp3 + if (me .eq. 0) write(6,*) 'this run is dead start run' + call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, + & vegfcs,vetfcs,sotfcs,alffcs, +!cwu [+1l] add ()fcs for sih, sic + & sihfcs,sicfcs, +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsfanl,wetanl,snoanl,zoranl,albanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,aisanl, + & veganl,vetanl,sotanl,alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & len,lsoil) + if(sig1t(1).ne.0.) then + call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, + & tsfimx) + do i=1,len + icefl2(i) = sicfcs(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + else + percrit=critp2 +! +! make reverse angulation correction to tsf +! make reverse orography correction to tg3 +! + if (use_ufo) then + orogd = orog - orog_uf +! +! The tiled version of the substrate temperature is properly +! adjusted to the terrain. Only invoke when using the old +! global tg3 grib file. +! + if ( index(fntg3c, "tileX.nc") == 0) then ! global file + ztsfc = 1.0 + call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) + endif + ztsfc = 0. + call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) + else + ztsfc = 0. + call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) + endif + +!clu [+12l] -------------------------------------------------------------- +! +! compute soil moisture liquid-to-total ratio over land +! + do j=1, lsoil + do i=1, len + if(smcfcs(i,j) .ne. 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo + enddo +!clu ----------------------------------------------------------------------- +! + if(lqcbgs .and. irtacn .eq. 0) then + call qcsli(slianl,slifcs,len,me) + call albocn(albfcs,slmask,albomx,len) + do i=1,len + icefl2(i) = sicfcs(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albf ',albfcs(1,kk),slifcs,snofcs,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + & then + call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorf ',zorfcs,slifcs,snofcs,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) +! call qcmxmn('plnf ',plrfcs,slifcs,snofcs,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3f ',tg3fcs,slifcs,snofcs,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] --------------------------------------------------------------- + call qcmxmn('sihf ',sihfcs,slifcs,snofcs,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcfcs(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcfcs(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetf ',vetfcs,slifcs,snofcs,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotf ',sotfcs,slifcs,snofcs,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +!clu [+16l] --------------------------------------------------------------- + call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxf ',vmxfcs,slifcs,snofcs,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpf ',slpfcs,slifcs,snofcs,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absf ',absfcs,slifcs,snofcs,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ----------------------------------------------------------------------- + endif + endif +! + if (monfcs) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of guess' + print *,' ' +! call count(slifcs,snofcs,len) + print *,' ' + call monitr('tsffcs',tsffcs,slifcs,snofcs,len) + call monitr('albfcs',albfcs,slifcs,snofcs,len) + call monitr('aisfcs',aisfcs,slifcs,snofcs,len) + call monitr('snofcs',snofcs,slifcs,snofcs,len) + call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) + call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) + call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) + call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) +!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) + if(lsoil.gt.2) then + call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) + call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) + call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) + call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) + endif + call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) + call monitr('zorfcs',zorfcs,slifcs,snofcs,len) +! if (gaus) then + call monitr('cvafcs',cvfcs ,slifcs,snofcs,len) + call monitr('cvbfcs',cvbfcs,slifcs,snofcs,len) + call monitr('cvtfcs',cvtfcs,slifcs,snofcs,len) +! endif + call monitr('slifcs',slifcs,slifcs,snofcs,len) +! call monitr('plrfcs',plrfcs,slifcs,snofcs,len) + call monitr('orog ',orog ,slifcs,snofcs,len) + call monitr('vegfcs',vegfcs,slifcs,snofcs,len) + call monitr('vetfcs',vetfcs,slifcs,snofcs,len) + call monitr('sotfcs',sotfcs,slifcs,snofcs,len) +!cwu [+2l] add sih, sic + call monitr('sihfcs',sihfcs,slifcs,snofcs,len) + call monitr('sicfcs',sicfcs,slifcs,snofcs,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnfcs',vmnfcs,slifcs,snofcs,len) + call monitr('vmxfcs',vmxfcs,slifcs,snofcs,len) + call monitr('slpfcs',slpfcs,slifcs,snofcs,len) + call monitr('absfcs',absfcs,slifcs,snofcs,len) + endif + endif +! +!... update annual cycle in the sst guess.. +! +! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) +! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) + + if (fh-deltsfc > -0.001 ) then + do i=1,len + if(slianl(i) == 0.0) then + tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i)) + endif + enddo + endif +! +! quality control analysis using forecast guess +! + call qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi,len,lsoil, + & snoanl,aisanl,slianl,tsfanl,albanl, + & zoranl,smcanl, + & smcclm,tsfsmx,albomx,zoromx,me) +! +! blend climatology and predicted fields +! + if(me .eq. 0) then + write(6,*) '==============' + write(6,*) ' merging' + write(6,*) '==============' + endif +! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) +! + percrit=critp3 +! +! merge analysis and forecast. note tg3, ais are not merged +! + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, + & cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, + & vetfcs,sotfcs,alffcs, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,veganl, + & vetanl,sotanl,alfanl, + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & calfl,calfs, + & csihl,csihs,csicl,csics, + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvmn,irtvmx,irtslp,irtabs, + & irtvet,irtsot,irtalf,landice,me) + + call setzro(snoanl,epssno,len) + +! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) +! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) + +! +! new ice/melted ice +! + call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, +!cwu [+1l] add sihnew, aislim, sihanl & sicanl + & sihnew,aislim,sihanl,sicanl, + & albanl,snoanl,zoranl,smcanl,stcanl, + & albomx,snoomx,zoromx,smcomx,smcimx, +!cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified +! & tsfomn,tsfimx,albimx,zorimx,tgice, + & tsfomn,tsfimx,albimn,zorimx,tgice, + & rla,rlo,me) + +! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) +! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) +! +! set tsfc to tsnow over snow +! + call snosfc(snoanl,tsfanl,tsfsmx,len,me) +! + do i=1,len + icefl2(i) = sicanl(i) .gt. 0.99999 + enddo + kqcm=0 + call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsfm ',tsfanl,slianl,snoanl,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albm ',albanl(1,kk),slianl,snoanl,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + & then + call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorm ',zoranl,slianl,snoanl,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) +! & then +! call qcmxmn('plntm ',plranl,slianl,snoanl,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + kqcm=1 + call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetm ',vetanl,slianl,snoanl,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotm ',sotanl,slianl,snoanl,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] add sih, sic, + call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l] add vmn, vmx, slp, abs + call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxm ',vmxanl,slianl,snoanl,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpm ',slpanl,slianl,snoanl,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absm ',absanl,slianl,snoanl,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +! + if(me .eq. 0) then + write(6,*) '==============' + write(6,*) 'final results' + write(6,*) '==============' + endif +! +! foreward correction to tg3 and tsf at the last stage +! +! if(lprnt) print *,' tsfbc=',tsfanl(iprnt) + if (use_ufo) then +! +! The tiled version of the substrate temperature is properly +! adjusted to the terrain. Only invoke when using the old +! global tg3 grib file. +! + if ( index(fntg3c, "tileX.nc") == 0) then ! global file + ztsfc = 1. + call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) + endif + ztsfc = 0. + call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) + else + ztsfc = 0. + call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) + endif +! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) +! +! check the final merged product +! + if (monmer) then + if(me .eq. 0) then + print *,' ' + print *,'monitor of updated surface fields' + print *,' (includes angulation correction)' + print *,' ' +! call count(slianl,snoanl,len) + print *,' ' + call monitr('tsfanl',tsfanl,slianl,snoanl,len) + call monitr('albanl',albanl,slianl,snoanl,len) + call monitr('aisanl',aisanl,slianl,snoanl,len) + call monitr('snoanl',snoanl,slianl,snoanl,len) + call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) +!clu [+4l] add smcanl(3:4) and stcanl(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) + endif +! if (gaus) then + call monitr('cvaanl',cvanl ,slianl,snoanl,len) + call monitr('cvbanl',cvbanl,slianl,snoanl,len) + call monitr('cvtanl',cvtanl,slianl,snoanl,len) +! endif + call monitr('slianl',slianl,slianl,snoanl,len) +! call monitr('plranl',plranl,slianl,snoanl,len) + call monitr('orog ',orog ,slianl,snoanl,len) + call monitr('cnpanl',cnpanl,slianl,snoanl,len) + call monitr('veganl',veganl,slianl,snoanl,len) + call monitr('vetanl',vetanl,slianl,snoanl,len) + call monitr('sotanl',sotanl,slianl,snoanl,len) +!cwu [+2l] add sih, sic, + call monitr('sihanl',sihanl,slianl,snoanl,len) + call monitr('sicanl',sicanl,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnanl',vmnanl,slianl,snoanl,len) + call monitr('vmxanl',vmxanl,slianl,snoanl,len) + call monitr('slpanl',slpanl,slianl,snoanl,len) + call monitr('absanl',absanl,slianl,snoanl,len) + endif + endif +! + if (mondif) then + do i=1,len + tsffcs(i) = tsfanl(i) - tsffcs(i) + snofcs(i) = snoanl(i) - snofcs(i) + tg3fcs(i) = tg3anl(i) - tg3fcs(i) + zorfcs(i) = zoranl(i) - zorfcs(i) +! plrfcs(i) = plranl(i) - plrfcs(i) +! albfcs(i) = albanl(i) - albfcs(i) + slifcs(i) = slianl(i) - slifcs(i) + aisfcs(i) = aisanl(i) - aisfcs(i) + cnpfcs(i) = cnpanl(i) - cnpfcs(i) + vegfcs(i) = veganl(i) - vegfcs(i) + vetfcs(i) = vetanl(i) - vetfcs(i) + sotfcs(i) = sotanl(i) - sotfcs(i) +!clu [+2l] add sih, sic + sihfcs(i) = sihanl(i) - sihfcs(i) + sicfcs(i) = sicanl(i) - sicfcs(i) +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) - vmnfcs(i) + vmxfcs(i) = vmxanl(i) - vmxfcs(i) + slpfcs(i) = slpanl(i) - slpfcs(i) + absfcs(i) = absanl(i) - absfcs(i) + enddo + do j = 1,lsoil + do i = 1,len + smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) + enddo + enddo + do j = 1,4 + do i = 1,len + albfcs(i,j) = albanl(i,j) - albfcs(i,j) + enddo + enddo +! +! monitoring prints +! + if(me .eq. 0) then + print *,' ' + print *,'monitor of difference' + print *,' (includes angulation correction)' + print *,' ' + call monitr('tsfdif',tsffcs,slianl,snoanl,len) + call monitr('albdif',albfcs,slianl,snoanl,len) + call monitr('albdif1',albfcs,slianl,snoanl,len) + call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) + call monitr('aisdif',aisfcs,slianl,snoanl,len) + call monitr('snodif',snofcs,slianl,snoanl,len) + call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) +!clu [+4l] add smcfcs(3:4) and stc(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) + endif + call monitr('tg3dif',tg3fcs,slianl,snoanl,len) + call monitr('zordif',zorfcs,slianl,snoanl,len) +! if (gaus) then + call monitr('cvadif',cvfcs ,slianl,snoanl,len) + call monitr('cvbdif',cvbfcs,slianl,snoanl,len) + call monitr('cvtdif',cvtfcs,slianl,snoanl,len) +! endif + call monitr('slidif',slifcs,slianl,snoanl,len) +! call monitr('plrdif',plrfcs,slianl,snoanl,len) + call monitr('cnpdif',cnpfcs,slianl,snoanl,len) + call monitr('vegdif',vegfcs,slianl,snoanl,len) + call monitr('vetdif',vetfcs,slianl,snoanl,len) + call monitr('sotdif',sotfcs,slianl,snoanl,len) +!cwu [+2l] add sih, sic + call monitr('sihdif',sihfcs,slianl,snoanl,len) + call monitr('sicdif',sicfcs,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmndif',vmnfcs,slianl,snoanl,len) + call monitr('vmxdif',vmxfcs,slianl,snoanl,len) + call monitr('slpdif',slpfcs,slianl,snoanl,len) + call monitr('absdif',absfcs,slianl,snoanl,len) + endif + endif +! +! + do i=1,len + tsffcs(i) = tsfanl(i) + snofcs(i) = snoanl(i) + tg3fcs(i) = tg3anl(i) + zorfcs(i) = zoranl(i) +! plrfcs(i) = plranl(i) +! albfcs(i) = albanl(i) + slifcs(i) = slianl(i) + aisfcs(i) = aisanl(i) + cvfcs(i) = cvanl(i) + cvbfcs(i) = cvbanl(i) + cvtfcs(i) = cvtanl(i) + cnpfcs(i) = cnpanl(i) + vegfcs(i) = veganl(i) + vetfcs(i) = vetanl(i) + sotfcs(i) = sotanl(i) +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) + vmxfcs(i) = vmxanl(i) + slpfcs(i) = slpanl(i) + absfcs(i) = absanl(i) + enddo + do j = 1,lsoil + do i = 1,len + smcfcs(i,j) = smcanl(i,j) + if (slifcs(i) .gt. 0.0) then + stcfcs(i,j) = stcanl(i,j) + else + stcfcs(i,j) = tsffcs(i) + endif + enddo + enddo + do j = 1,4 + do i = 1,len + albfcs(i,j) = albanl(i,j) + enddo + enddo + do j = 1,2 + do i = 1,len + alffcs(i,j) = alfanl(i,j) + enddo + enddo + +!cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points + crit=aislim + do i=1,len + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (slifcs(i).ge.2.) then + if (sicfcs(i).gt.crit) then + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) + else + tsffcs(i) = tsfanl(i) +! tsffcs(i) = tgice + sihfcs(i) = sihnew + endif + endif + sicfcs(i) = sicanl(i) + enddo + do i=1,len + if (slifcs(i).lt.1.5) then + sihfcs(i) = 0. + sicfcs(i) = 0. + sitfcs(i) = tsffcs(i) + else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then + print *,'warning: check, slifcs and sicfcs', + & slifcs(i),sicfcs(i) + endif + enddo + +! +! ensure the consistency between slc and smc +! + do k=1, lsoil + fixratio(k) = .false. + if (fsmcl(k).lt.99999.) fixratio(k) = .true. + enddo + + if(me .eq. 0) then + print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) + endif + + do k=1, lsoil + if(fixratio(k)) then + do i = 1, len + if(swratio(i,k) .eq. -999.) then + slcfcs(i,k) = smcfcs(i,k) + else + slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) + endif + if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. + enddo + endif + enddo +! set liquid soil moisture to a flag value of 1.0 + if (landice) then + do i = 1, len + if (slifcs(i) .eq. 1.0 .and. + & nint(vetfcs(i)) == veg_type_landice) then + do k=1, lsoil + slcfcs(i,k) = 1.0 + enddo + endif + enddo + end if +! +! ensure the consistency between snwdph and sheleg +! + if(fsnol .lt. 99999.) then + if(me .eq. 0) then + print *,'dbgx -- scale snwdph from sheleg' + endif + do i = 1, len + if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) + enddo + endif + +! sea ice model only uses the liquid equivalent depth. +! so update the physical depth only for display purposes. +! use the same 3:1 ratio used by ice model. + + do i = 1, len + if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) + enddo + + do i = 1, len + if(slifcs(i).eq.1.) then + if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then + print *,'dbgx --scale snwdph from sheleg', + + i, swdfcs(i), snofcs(i) + swdfcs(i) = 10.* snofcs(i) + endif + endif + enddo +! landice mods - impose same minimum snow depth at +! landice as noah lsm. also ensure +! lower thermal boundary condition +! and skin t is no warmer than freezing +! after adjustment to terrain. + if (landice) then + do i = 1, len + if (slifcs(i) .eq. 1.0 .and. + & nint(vetfcs(i)) == veg_type_landice) then + snofcs(i) = max(snofcs(i),100.0) ! in mm + swdfcs(i) = max(swdfcs(i),1000.0) ! in mm + tg3fcs(i) = min(tg3fcs(i),273.15) + tsffcs(i) = min(tsffcs(i),273.15) + endif + enddo + end if +! +! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) + return + end subroutine sfccycle + +!>\ingroup mod_sfcsub +!! This subroutine counts number of points for the four surface +!! conditions. + subroutine count(slimsk,sno,ijmax) + use machine , only : kind_io8,kind_io4 + implicit none + real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5 + integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij +! + real (kind=kind_io8) slimsk(1),sno(1) +! +! count number of points for the four surface conditions +! + l0 = 0 + l1 = 0 + l2 = 0 + l3 = 0 + l4 = 0 + do ij=1,ijmax + if(slimsk(ij).eq.0.) l1 = l1 + 1 + if(slimsk(ij).eq.1. .and. sno(ij).le.0.) l0 = l0 + 1 + if(slimsk(ij).eq.2. .and. sno(ij).le.0.) l2 = l2 + 1 + if(slimsk(ij).eq.1. .and. sno(ij).gt.0.) l3 = l3 + 1 + if(slimsk(ij).eq.2. .and. sno(ij).gt.0.) l4 = l4 + 1 + enddo + l5 = l0 + l3 + l6 = l2 + l4 + l7 = l1 + l6 + l8 = l1 + l5 + l6 + rl0 = float(l0) / float(l8)*100. + rl3 = float(l3) / float(l8)*100. + rl1 = float(l1) / float(l8)*100. + rl2 = float(l2) / float(l8)*100. + rl4 = float(l4) / float(l8)*100. + rl5 = float(l5) / float(l8)*100. + rl6 = float(l6) / float(l8)*100. + rl7 = float(l7) / float(l8)*100. + print *,'1) no. of not snow-covered land points ',l0,' ',rl0,' ' + print *,'2) no. of snow covered land points ',l3,' ',rl3,' ' + print *,'3) no. of open sea points ',l1,' ',rl1,' ' + print *,'4) no. of not snow-covered seaice points ',l2,' ',rl2,' ' + print *,'5) no. of snow covered sea ice points ',l4,' ',rl4,' ' + print *,' ' + print *,'6) no. of land points ',l5,' ',rl5,' ' + print *,'7) no. sea points (including sea ice) ',l7,' ',rl7,' ' + print *,' (no. of sea ice points) (',l6,')',' ',rl6,' ' + print *,' ' + print *,'9) no. of total grid points ',l8 +! print *,' ' +! print *,' ' + +! +! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) + return + end + +!>\ingroup mod_sfcsub + subroutine monitr(lfld,fld,slimsk,sno,ijmax) + use machine , only : kind_io8,kind_io4 + implicit none + integer ij,n,ijmax +! + real (kind=kind_io8) fld(ijmax), slimsk(ijmax),sno(ijmax) +! + real (kind=kind_io8) rmax(5),rmin(5) + character(len=*) lfld +! +! find max/min +! + do n=1,5 + rmax(n) = -9.e20 + rmin(n) = 9.e20 + enddo +! + do ij=1,ijmax + if(slimsk(ij).eq.0.) then + rmax(1) = max(rmax(1), fld(ij)) + rmin(1) = min(rmin(1), fld(ij)) + elseif(slimsk(ij).eq.1.) then + if(sno(ij).le.0.) then + rmax(2) = max(rmax(2), fld(ij)) + rmin(2) = min(rmin(2), fld(ij)) + else + rmax(4) = max(rmax(4), fld(ij)) + rmin(4) = min(rmin(4), fld(ij)) + endif + else + if(sno(ij).le.0.) then + rmax(3) = max(rmax(3), fld(ij)) + rmin(3) = min(rmin(3), fld(ij)) + else + rmax(5) = max(rmax(5), fld(ij)) + rmin(5) = min(rmin(5), fld(ij)) + endif + endif + enddo +! + print 100,lfld + print 101,rmax(1),rmin(1) + print 102,rmax(2),rmin(2), rmax(4), rmin(4) + print 103,rmax(3),rmin(3), rmax(5), rmin(5) +! +! print 102,rmax(2),rmin(2) +! print 103,rmax(3),rmin(3) +! print 104,rmax(4),rmin(4) +! print 105,rmax(5),rmin(5) + 100 format('0 *** ',a8,' ***') + 101 format(' open sea ......... max=',e12.4,' min=',e12.4) + 102 format(' land nosnow/snow .. max=',e12.4,' min=',e12.4 + &, ' max=',e12.4,' min=',e12.4) + 103 format(' seaice nosnow/snow max=',e12.4,' min=',e12.4 + &, ' max=',e12.4,' min=',e12.4) +! +! 100 format('0',2x,'*** ',a8,' ***') +! 102 format(2x,' land without snow ..... max=',e12.4,' min=',e12.4) +! 103 format(2x,' seaice without snow ... max=',e12.4,' min=',e12.4) +! 104 format(2x,' land with snow ........ max=',e12.4,' min=',e12.4) +! 105 format(2x,' sea ice with snow ..... max=',e12.4,' min=',e12.4) +! + return + end + +!>\ingroup mod_sfcsub +!! This subroutine figures out the day of the year given imo and idy. + subroutine dayoyr(iyr,imo,idy,ldy) + implicit none + integer ldy,i,idy,iyr,imo +! +! this routine figures out the day of the year given imo and idy +! + integer month(13) + data month/0,31,28,31,30,31,30,31,31,30,31,30,31/ + if(mod(iyr,4).eq.0) month(3) = 29 + ldy = idy + do i = 1, imo + ldy = ldy + month(i) + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, + & kpds5,slmskh,gausm,blnmsk,bltmsk,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, xdata, ydata + implicit none + integer kpds5,me,i,imsk,jmsk,lugb +! + character*500 fnmskh +! + real (kind=kind_io8) slmskh(mdata) + logical gausm + real (kind=kind_io8) blnmsk,bltmsk +! + imsk = xdata + jmsk = ydata + + if (me .eq. 0) then + write(6,*)' imsk=',imsk,' jmsk=',jmsk,' xdata=',xdata,' ydata=' + &, ydata + endif + + call fixrdg(lugb,imsk,jmsk,fnmskh, + & kpds5,slmskh,gausm,blnmsk,bltmsk,me) + +! print *,'in sfc_sub, aft fixrdg,slmskh=',maxval(slmskh), +! & minval(slmskh),'mdata=',mdata,'imsk*jmsk=',imsk*jmsk + + do i=1,imsk*jmsk + slmskh(i) = nint(slmskh(i)) + enddo +! + return + end + +!>\ingroup mod_sfcsub + subroutine fixrdg(lugb,idim,jdim,fngrib, + & kpds5,gdata,gaus,blno,blto,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata + implicit none + integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb, + & iret, me,kpds5,kdata,i,w3kindreal,w3kindint +! + character*(*) fngrib +! + real (kind=kind_io8) gdata(idim*jdim) + logical gaus + real (kind=kind_io8) blno,blto + real (kind=kind_io8), allocatable :: data8(:) + real (kind=kind_io4), allocatable :: data4(:) +! + logical*1, allocatable :: lbms(:) +! + integer kpds(200),kgds(200) + integer jpds(200),jgds(200), kpds0(200) +! + allocate(data8(1:idim*jdim)) + allocate(lbms(1:mdata)) + kpds = 0 + kgds = 0 + jpds = 0 + jgds = 0 + kpds0 = 0 +! +! if(me .eq. 0) then +! write(6,*) ' ' +! write(6,*) '************************************************' +! endif +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0) write(6,*) ' file ',trim(fngrib), + & ' opened. unit=',lugb + lugi = 0 + lskip = -1 + n = 0 + jpds = -1 + jgds = -1 + jpds(5) = kpds5 + kpds = jpds +! + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) +! + if(me .eq. 0) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif +! + kpds0=jpds + kpds0(4)=-1 + kpds0(18)=-1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if (iret == 99) write(6,*) ' field not found.' + call abort + endif +! + jpds = kpds0 + lskip = -1 + kdata=idim*jdim + call w3kind(w3kindreal,w3kindint) + if (w3kindreal == 8) then + call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + else if (w3kindreal == 4) then + allocate(data4(1:idim*jdim)) + call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = real(data4, kind=kind_io8) + deallocate(data4) + else + write(0,*)' Invalid w3kindreal --- aborting' + call abort + endif +! + if(jret == 0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + idim = kgds(2) + jdim = kgds(3) + gaus = kgds(1).eq.4 + blno = kgds(5)*1.d-3 + blto = kgds(4)*1.d-3 + gdata(1:idim*jdim) = data8(1:idim*jdim) + if (me == 0) write(6,*) 'idim,jdim=',idim,jdim + &, ' gaus=',gaus,' blno=',blno,' blto=',blto + else + if (me ==. 0) write(6,*) 'idim,jdim=',idim,jdim + &, ' gaus=',gaus,' blno=',blno,' blto=',blto + write(6,*) ' error in getgb : jret=',jret + write(6,*) ' kpds(13)=',kpds(13),' kpds(15)=',kpds(15) + call abort + endif +! + deallocate(data8) + deallocate(lbms) + return + end + +!>\ingroup mod_sfcsub +!! This subroutine get area of the grib record. + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr + &, me) + use machine , only : kind_io8,kind_io4 + implicit none + integer j,me,kgds11 + real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat +! +! get area of the grib record +! + integer kgds(22) + logical ijordr +! + if (me .eq. 0) then + write(6,*) ' kgds( 1-12)=',(kgds(j),j= 1,12) + write(6,*) ' kgds(13-22)=',(kgds(j),j=13,22) + endif +! + if(kgds(1).eq.0) then ! lat/lon grid +! + if (me .eq. 0) write(6,*) 'lat/lon grid' + dlat = float(kgds(10)) * 0.001 + dlon = float(kgds( 9)) * 0.001 + f0lon = float(kgds(5)) * 0.001 + f0lat = float(kgds(4)) * 0.001 + kgds11 = kgds(11) + if(kgds11.ge.128) then + wlon = f0lon - dlon*(kgds(2)-1) + elon = f0lon + if(dlon*kgds(2).gt.359.99) then + wlon =f0lon - dlon*kgds(2) + endif + dlon = -dlon + kgds11 = kgds11 - 128 + else + wlon = f0lon + elon = f0lon + dlon*(kgds(2)-1) + if(dlon*kgds(2).gt.359.99) then + elon = f0lon + dlon*kgds(2) + endif + endif + if(kgds11.ge.64) then + rnlat = f0lat + dlat*(kgds(3)-1) + rslat = f0lat + kgds11 = kgds11 - 64 + else + rnlat = f0lat + rslat = f0lat - dlat*(kgds(3)-1) + dlat = -dlat + endif + if(kgds11.ge.32) then + ijordr = .false. + else + ijordr = .true. + endif + + if(wlon.gt.180.) wlon = wlon - 360. + if(elon.gt.180.) elon = elon - 360. + wlon = nint(wlon*1000.) * 0.001 + elon = nint(elon*1000.) * 0.001 + rslat = nint(rslat*1000.) * 0.001 + rnlat = nint(rnlat*1000.) * 0.001 + return +! + elseif(kgds(1).eq.1) then ! mercator projection + write(6,*) 'mercator grid' + write(6,*) 'cannot process' + call abort +! + elseif(kgds(1).eq.2) then ! gnomonic projection + write(6,*) 'gnomonic grid' + write(6,*) 'error!! gnomonic projection not coded' + call abort +! + elseif(kgds(1).eq.3) then ! lambert conformal + write(6,*) 'lambert conformal' + write(6,*) 'cannot process' + call abort + elseif(kgds(1).eq.4) then ! gaussian grid +! + if (me .eq. 0) write(6,*) 'gaussian grid' + dlat = 99. + dlon = float(kgds( 9)) / 1000.0 + f0lon = float(kgds(5)) / 1000.0 + f0lat = 99. + kgds11 = kgds(11) + if(kgds11.ge.128) then + wlon = f0lon + elon = f0lon + if(dlon*kgds(2).gt.359.99) then + wlon = f0lon - dlon*kgds(2) + endif + dlon = -dlon + kgds11 = kgds11-128 + else + wlon = f0lon + elon = f0lon + dlon*(kgds(2)-1) + if(dlon*kgds(2).gt.359.99) then + elon = f0lon + dlon*kgds(2) + endif + endif + if(kgds11.ge.64) then + rnlat = 99. + rslat = 99. + kgds11 = kgds11 - 64 + else + rnlat = 99. + rslat = 99. + dlat = -99. + endif + if(kgds11.ge.32) then + ijordr = .false. + else + ijordr = .true. + endif + return +! + elseif(kgds(1).eq.5) then ! polar strereographic + write(6,*) 'polar stereographic grid' + write(6,*) 'cannot process' + call abort + return +! + elseif(kgds(1).eq.13) then ! oblique lambert conformal + write(6,*) 'oblique lambert conformal grid' + write(6,*) 'cannot process' + call abort +! + elseif(kgds(1).eq.50) then ! spherical coefficient + write(6,*) 'spherical coefficient' + write(6,*) 'cannot process' + call abort + return +! + elseif(kgds(1).eq.90) then ! space view perspective +! (orthographic grid) + write(6,*) 'space view perspective grid' + write(6,*) 'cannot process' + call abort + return +! + else ! unknown projection. abort. + write(6,*) 'error!! unknown map projection' + write(6,*) 'kgds(1)=',kgds(1) + print *,'error!! unknown map projection' + print *,'kgds(1)=',kgds(1) + call abort + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine subst(data,imax,jmax,dlon,dlat,ijordr) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,ii,jj,jmax,imax,iret + real (kind=kind_io8) dlat,dlon +! + logical ijordr +! + real (kind=kind_io8) data(imax,jmax) + real (kind=kind_io8), allocatable :: work(:,:) +! + if(.not.ijordr.or. + & (ijordr.and.(dlat.gt.0..or.dlon.lt.0.))) then + allocate (work(imax,jmax)) + + if(.not.ijordr) then + do j=1,jmax + do i=1,imax + work(i,j) = data(j,i) + enddo + enddo + else + do j=1,jmax + do i=1,imax + work(i,j) = data(i,j) + enddo + enddo + endif + if (dlat > 0.0) then + if (dlon > 0.0) then + do j=1,jmax + jj = jmax - j + 1 + do i=1,imax + data(i,jj) = work(i,j) + enddo + enddo + else + do i=1,imax + data(imax-i+1,jj) = work(i,j) + enddo + endif + else + if (dlon > 0.0) then + do j=1,jmax + do i=1,imax + data(i,j) = work(i,j) + enddo + enddo + else + do j=1,jmax + do i=1,imax + data(imax-i+1,j) = work(i,j) + enddo + enddo + endif + endif + deallocate (work, stat=iret) + endif + return + end + +!>\ingroup mod_sfcsub +!! This subroutine conducts interpolation from lat/lon to Gaussian +!! grid to other lat/lon grid. + subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, + & gauout,len,lmask,rslmsk,slmask + &, outlat, outlon,me) + use machine , only : kind_io8,kind_io4 + implicit none + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, + & wi1j2,wi2j1,rlat,rlon,aphi, + & rnume,alamd,denom + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, + & ii,i1,i2,kmami,it + integer nx,kxs,kxt + integer, allocatable, save :: imxnx(:) + integer, allocatable :: ifill(:) +! +! interpolation from lat/lon or gaussian grid to other lat/lon grid +! + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), + & slmask(len) + real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) +! + real (kind=kind_io8) rinlat(jmxin), rinlon(imxin) + integer iindx1(len), iindx2(len) + integer jindx1(len), jindx2(len) + real (kind=kind_io8) ddx(len), ddy(len), wrk(len) +! + logical lmask +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, len_thread, i1_t, i2_t + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + if (.not. allocated(imxnx)) allocate (imxnx(num_threads)) + endif +! +! if (me == 0) print *,' num_threads =',num_threads,' me=',me +! +! if(me .eq. 0) then +! print *,'rlon=',rlon,' me=',me +! print *,'rlat=',rlat,' me=',me,' imxin=',imxin,' jmxin=',jmxin +! endif +! +! do j=1,jmxin +! if(rlat.gt.0.) then +! rinlat(j) = rlat - float(j-1)*dlain +! else +! rinlat(j) = rlat + float(j-1)*dlain +! endif +! enddo +! +! if (me .eq. 0) then +! print *,'rinlat=' +! print *,(rinlat(j),j=1,jmxin) +! print *,'rinlon=' +! print *,(rinlon(i),i=1,imxin) +! +! print *,'outlat=' +! print *,(outlat(j),j=1,len) +! print *,(outlon(j),j=1,len) +! endif +! +! do i=1,imxin +! rinlon(i) = rlon + float(i-1)*dloin +! enddo +! +! print *,'rinlon=' +! print *,(rinlon(i),i=1,imxin) +! + len_thread_m = (len+num_threads-1) / num_threads + + if (inttyp /=1) allocate (ifill(num_threads)) +! +!$omp parallel do default(none) +!$omp+private(i1_t,i2_t,len_thread,it,i,ii,i1,i2) +!$omp+private(j,j1,j2,jq,ix,jy,nx,kxs,kxt,kmami) +!$omp+private(alamd,denom,rnume,aphi,x,y,wsum,wsumiv,sum1,sum2) +!$omp+private(sum3,sum4,wi1j1,wi2j1,wi1j2,wi2j2,wei1,wei2,wei3,wei4) +!$omp+private(sumn,sums) +!$omp+shared(imxin,jmxin,ifill) +!$omp+shared(outlon,outlat,wrk,iindx1,rinlon,jindx1,rinlat,ddx,ddy) +!$omp+shared(rlon,rlat,regin,gauout,imxnx) +!$omp+private(tem) +!$omp+shared(num_threads,len_thread_m,len,lmask,iindx2,jindx2,rslmsk) +!$omp+shared(inttyp,me,slmask) +! + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) + len_thread = i2_t-i1_t+1 +! +! find i-index for interpolation +! + do i=i1_t, i2_t + alamd = outlon(i) + if (alamd .lt. rlon) alamd = alamd + 360.0 + if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 + wrk(i) = alamd + iindx1(i) = imxin + enddo + do i=i1_t,i2_t + do ii=1,imxin + if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii + enddo + enddo + do i=i1_t,i2_t + i1 = iindx1(i) + if (i1 .lt. 1) i1 = imxin + i2 = i1 + 1 + if (i2 .gt. imxin) i2 = 1 + iindx1(i) = i1 + iindx2(i) = i2 + denom = rinlon(i2) - rinlon(i1) + if(denom.lt.0.) denom = denom + 360. + rnume = wrk(i) - rinlon(i1) + if(rnume.lt.0.) rnume = rnume + 360. + ddx(i) = rnume / denom + enddo +! +! find j-index for interplation +! + if(rlat.gt.0.) then + do j=i1_t,i2_t + jindx1(j)=0 + enddo + do jx=1,jmxin + do j=i1_t,i2_t + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=i1_t,i2_t + jq = jindx1(j) + aphi=outlat(j) + if(jq.ge.1 .and. jq .lt. jmxin) then + j2=jq+1 + j1=jq + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 0) then + j2=1 + j1=1 + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + else + do j=i1_t,i2_t + jindx1(j) = jmxin+1 + enddo + do jx=jmxin,1,-1 + do j=i1_t,i2_t + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=i1_t,i2_t + jq = jindx1(j) + aphi=outlat(j) + if(jq.gt.1 .and. jq .le. jmxin) then + j2=jq + j1=jq-1 + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 1) then + j2=1 + j1=1 + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + endif +! +! if (me .eq. 0 .and. inttyp .eq. 1) then +! print *,'la2ga' +! print *,'iindx1' +! print *,(iindx1(n),n=1,len) +! print *,'iindx2' +! print *,(iindx2(n),n=1,len) +! print *,'jindx1' +! print *,(jindx1(n),n=1,len) +! print *,'jindx2' +! print *,(jindx2(n),n=1,len) +! print *,'ddy' +! print *,(ddy(n),n=1,len) +! print *,'ddx' +! print *,(ddx(n),n=1,len) +! endif +! + sum1 = 0. + sum2 = 0. + sum3 = 0. + sum4 = 0. + if (lmask) then + wei1 = 0. + wei2 = 0. + wei3 = 0. + wei4 = 0. + do i=1,imxin + sum1 = sum1 + regin(i,1) * rslmsk(i,1) + sum2 = sum2 + regin(i,jmxin) * rslmsk(i,jmxin) + wei1 = wei1 + rslmsk(i,1) + wei2 = wei2 + rslmsk(i,jmxin) +! + sum3 = sum3 + regin(i,1) * (1.0-rslmsk(i,1)) + sum4 = sum4 + regin(i,jmxin) * (1.0-rslmsk(i,jmxin)) + wei3 = wei3 + (1.0-rslmsk(i,1)) + wei4 = wei4 + (1.0-rslmsk(i,jmxin)) + enddo +! + if(wei1.gt.0.) then + sum1 = sum1 / wei1 + else + sum1 = 0. + endif + if(wei2.gt.0.) then + sum2 = sum2 / wei2 + else + sum2 = 0. + endif + if(wei3.gt.0.) then + sum3 = sum3 / wei3 + else + sum3 = 0. + endif + if(wei4.gt.0.) then + sum4 = sum4 / wei4 + else + sum4 = 0. + endif + else + do i=1,imxin + sum1 = sum1 + regin(i,1) + sum2 = sum2 + regin(i,jmxin) + enddo + sum1 = sum1 / imxin + sum2 = sum2 / imxin + sum3 = sum1 + sum4 = sum2 + endif +! +! print *,' sum1=',sum1,' sum2=',sum2 +! *,' sum3=',sum3,' sum4=',sum4 +! print *,' rslmsk=',(rslmsk(i,1),i=1,imxin) +! print *,' slmask=',(slmask(i),i=1,imxout) +! *,' j1=',jindx1(1),' j2=',jindx2(1) +! +! +! inttyp=1 take the closest point value +! + if(inttyp.eq.1) then + + do i=i1_t,i2_t + jy = jindx1(i) + if(ddy(i) .ge. 0.5) jy = jindx2(i) + ix = iindx1(i) + if(ddx(i) .ge. 0.5) ix = iindx2(i) +! +!cggg start +! + if (.not. lmask) then + + gauout(i) = regin(ix,jy) + + else + + if(slmask(i).eq.rslmsk(ix,jy)) then + + gauout(i) = regin(ix,jy) + + else + + i1 = ix + j1 = jy + +! spiral around until matching mask is found. + do nx=1,jmxin*imxin/2 + kxs=sqrt(4*nx-2.5) + kxt=nx-int(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-kxs/4+kxt + jx=j1-kxs/4 + case(2) + ix=i1+1+kxs/4 + jx=j1-kxs/4+kxt + case(3) + ix=i1+1+kxs/4-kxt + jx=j1+1+kxs/4 + case default + ix=i1-kxs/4 + jx=j1+kxs/4-kxt + end select + if(jx.lt.1) then + ix=ix+imxin/2 + jx=2-jx + elseif(jx.gt.jmxin) then + ix=ix+imxin/2 + jx=2*jmxin-jx + endif + ix=modulo(ix-1,imxin)+1 + if(slmask(i).eq.rslmsk(ix,jx)) then + gauout(i) = regin(ix,jx) + go to 81 + endif + enddo + +!cggg here, set the gauout value to be 0, and let's sarah's land +!cggg routine assign a default. + + if (num_threads == 1) then + print*,'no matching mask found ',i,i1,j1,ix,jx + print*,'set to default value.' + endif + gauout(i) = 0.0 + + + 81 continue + + end if + + end if + +!cggg end + + enddo +! kmami=1 +! if (me == 0 .and. num_threads == 1) +! & call maxmin(gauout(i1_t),len_thread,kmami) + else ! nearest neighbor interpolation + +! +! quasi-bilinear interpolation +! + ifill(it) = 0 + imxnx(it) = 0 + do i=i1_t,i2_t + y = ddy(i) + j1 = jindx1(i) + j2 = jindx2(i) + x = ddx(i) + i1 = iindx1(i) + i2 = iindx2(i) +! + wi1j1 = (1.-x) * (1.-y) + wi2j1 = x *( 1.-y) + wi1j2 = (1.-x) * y + wi2j2 = x * y +! + tem = 4.*slmask(i) - rslmsk(i1,j1) - rslmsk(i2,j1) + & - rslmsk(i1,j2) - rslmsk(i2,j2) + if(lmask .and. abs(tem) .gt. 0.01) then + if(slmask(i).eq.1.) then + wi1j1 = wi1j1 * rslmsk(i1,j1) + wi2j1 = wi2j1 * rslmsk(i2,j1) + wi1j2 = wi1j2 * rslmsk(i1,j2) + wi2j2 = wi2j2 * rslmsk(i2,j2) + else + wi1j1 = wi1j1 * (1.0-rslmsk(i1,j1)) + wi2j1 = wi2j1 * (1.0-rslmsk(i2,j1)) + wi1j2 = wi1j2 * (1.0-rslmsk(i1,j2)) + wi2j2 = wi2j2 * (1.0-rslmsk(i2,j2)) + endif + endif +! + wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 + wrk(i) = wsum + if(wsum.ne.0.) then + wsumiv = 1./wsum +! + if(j1.ne.j2) then + gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + + & wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) + & *wsumiv + else +! + if (rlat .gt. 0.0) then + if (slmask(i) .eq. 1.0) then + sumn = sum1 + sums = sum2 + else + sumn = sum3 + sums = sum4 + endif + if( j1 .eq. 1) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + + & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) + & * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ + & wi1j2*sums +wi2j2*sums ) + & * wsumiv + endif +! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn +! & ,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2 +! & ,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv + else + if (slmask(i) .eq. 1.0) then + sums = sum1 + sumn = sum2 + else + sums = sum3 + sumn = sum4 + endif + if( j1 .eq. 1) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ + & wi1j2*sums +wi2j2*sums ) + & * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + + & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) + & * wsumiv + endif + endif + endif ! if j1 .ne. j2 + endif + enddo + do i=i1_t,i2_t + j1 = jindx1(i) + j2 = jindx2(i) + i1 = iindx1(i) + i2 = iindx2(i) + if(wrk(i) .eq. 0.0) then + if(.not.lmask) then + if (num_threads == 1) + & write(6,*) ' la2ga called with lmask=.true. but bad', + & ' rslmsk or slmask given' + call abort + endif + ifill(it) = ifill(it) + 1 + if(ifill(it) <= 2 ) then + if (me == 0 .and. num_threads == 1) then + write(6,*) 'i1,i2,j1,j2=',i1,i2,j1,j2 + write(6,*) 'rslmsk=',rslmsk(i1,j1),rslmsk(i1,j2), + & rslmsk(i2,j1),rslmsk(i2,j2) +! write(6,*) 'i,j=',i,j,' slmask(i)=',slmask(i) + write(6,*) 'i=',i,' slmask(i)=',slmask(i) + &, ' outlon=',outlon(i),' outlat=',outlat(i) + endif + endif +! spiral around until matching mask is found. + do nx=1,jmxin*imxin/2 + kxs=sqrt(4*nx-2.5) + kxt=nx-int(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-kxs/4+kxt + jx=j1-kxs/4 + case(2) + ix=i1+1+kxs/4 + jx=j1-kxs/4+kxt + case(3) + ix=i1+1+kxs/4-kxt + jx=j1+1+kxs/4 + case default + ix=i1-kxs/4 + jx=j1+kxs/4-kxt + end select + if(jx.lt.1) then + ix=ix+imxin/2 + jx=2-jx + elseif(jx.gt.jmxin) then + ix=ix+imxin/2 + jx=2*jmxin-jx + endif + ix=modulo(ix-1,imxin)+1 + if(slmask(i).eq.rslmsk(ix,jx)) then + gauout(i) = regin(ix,jx) + imxnx(it) = max(imxnx(it),nx) + go to 71 + endif + enddo +! + if (num_threads == 1) then + write(6,*) ' error!!! no filling value found in la2ga' +! write(6,*) ' i ix jx slmask(i) rslmsk ', +! & i,ix,jx,slmask(i),rslmsk(ix,jx) + endif + call abort +! + 71 continue + endif +! + enddo + endif + enddo ! end of threaded loop ................... +!$omp end parallel do +! + if(inttyp /= 1)then + ifills = 0 + do it=1,num_threads + ifills = ifills + ifill(it) + enddo + + if(ifills.gt.1) then + if (me .eq. 0) then + write(6,*) ' unable to interpolate. filled with nearest', + & ' point value at ',ifills,' points' +! & ' point value at ',ifills,' points imxnx=',imxnx(:) + endif + endif + deallocate (ifill) + endif +! +! kmami = 1 +! if (me == 0) call maxmin(gauout,len,kmami) +! + return + end subroutine la2ga + +!>\ingroup mod_sfcsub + subroutine maxmin(f,imax,kmax) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,iimin,iimax,kmax,imax,k + real (kind=kind_io8) fmin,fmax +! + real (kind=kind_io8) f(imax,kmax) +! + do k=1,kmax +! + fmax = f(1,k) + fmin = f(1,k) +! + do i=1,imax + if(fmax.le.f(i,k)) then + fmax = f(i,k) + iimax = i + endif + if(fmin.ge.f(i,k)) then + fmin = f(i,k) + iimin = i + endif + enddo +! +! write(6,100) k,fmax,iimax,fmin,iimin +! 100 format(2x,'level=',i2,' max=',e11.4,' at i=',i7, +! & ' min=',e11.4,' at i=',i7) +! + enddo +! + return + end + +!>\ingroup mod_sfcsub + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, + & aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, + & vetanl,sotanl,alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, + & aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, + & vetclm,sotclm,alfclm, +!cwu [+1l] add ()clm for sih, sic + & sihclm,sicclm, +!clu [+1l] add ()clm for vmn, vmx, slp, abs + & vmnclm,vmxclm,slpclm,absclm, + & len,lsoil) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil +! + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), + & snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),scvanl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), + & snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) +!cwu [+1l] add ()clm for sih, sic + &, sihclm(len),sicclm(len) +!clu [+1l] add ()clm for vmn, vmx, slp, abs + &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) +! + do i=1,len + tsfanl(i) = tsfclm(i) ! tsf at t + tsfan2(i) = tsfcl2(i) ! tsf at t-deltsfc + wetanl(i) = wetclm(i) ! soil wetness + snoanl(i) = snoclm(i) ! snow + scvanl(i) = scvclm(i) ! snow cover + aisanl(i) = aisclm(i) ! seaice + slianl(i) = sliclm(i) ! land/sea/snow mask + zoranl(i) = zorclm(i) ! surface roughness +! plranl(i) = plrclm(i) ! maximum stomatal resistance + tg3anl(i) = tg3clm(i) ! deep soil temperature + cnpanl(i) = cnpclm(i) ! canopy water content + veganl(i) = vegclm(i) ! vegetation cover + vetanl(i) = vetclm(i) ! vegetation type + sotanl(i) = sotclm(i) ! soil type + cvanl(i) = cvclm(i) ! cv + cvbanl(i) = cvbclm(i) ! cvb + cvtanl(i) = cvtclm(i) ! cvt +!cwu [+4l] add sih, sic + sihanl(i) = sihclm(i) ! sea ice thickness + sicanl(i) = sicclm(i) ! sea ice concentration +!clu [+4l] add vmn, vmx, slp, abs + vmnanl(i) = vmnclm(i) ! min vegetation cover + vmxanl(i) = vmxclm(i) ! max vegetation cover + slpanl(i) = slpclm(i) ! slope type + absanl(i) = absclm(i) ! max snow albedo + enddo +! + do j=1,lsoil + do i=1,len + smcanl(i,j) = smcclm(i,j) ! layer soil wetness + stcanl(i,j) = stcclm(i,j) ! soil temperature + enddo + enddo + do j=1,4 + do i=1,len + albanl(i,j) = albclm(i,j) ! albedo + enddo + enddo + do j=1,2 + do i=1,len + alfanl(i,j) = alfclm(i,j) ! vegetation fraction for albedo + enddo + enddo +! + return + end + +!>\ingroup mod_sfcsub + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota, +!clu [+1l] add fn()a for vmn, vmx, slp, abs + & fnvmna,fnvmxa,fnslpa,fnabsa, + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, + & vetanl,sotanl,alfanl,tsfan0, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, +!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, +!cggg snow mods end + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kprvet,kpdsot,kpdalf, +!clu [+1l] add kpd() for vmn, vmx, slp, abs + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvet,irtsot,irtalf +!clu [+1l] add irt() for vmn, vmx, slp, abs + &, irtvmn,irtvmx,irtslp,irtabs + &, imsk, jmsk, slmskh, outlat, outlon + &, gaus, blno, blto, me, lanom) + use machine , only : kind_io8,kind_io4 + implicit none + logical lanom + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, +!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, +!cggg snow mods end + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j +!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs + &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs + real (kind=kind_io8) blto,blno,fh +! + real (kind=kind_io8) slmask(len) + real (kind=kind_io8) slmskh(imsk,jmsk) + real (kind=kind_io8) outlat(len), outlon(len) + integer kpdalb(4), kpdalf(2) +!cggg snow mods start + integer kpds(1000),kgds(1000),jpds(1000),jgds(1000) + integer lugi, lskip, lgrib, ndata +!cggg snow mods end +! + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota +!clu [+1l] add fn()a for vmn, vmx, slp, abs + &, fnvmna,fnvmxa,fnslpa,fnabsa + + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & slianl(len), scvanl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), + & smcanl(len,lsoil), stcanl(len,lsoil), + & tsfan0(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + logical gaus +! +! tsf +! + irttsf = 1 + if(fntsfa(1:8).ne.' ') then + call fixrda(lugb,fntsfa,kpdtsf,slmask, + & iy,im,id,ih,fh,tsfanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irttsf = iret + if(iret == 1) then + write(6,*) 't surface analysis read error' + call abort + elseif(iret == -1) then + if (me == 0) then + print *,'old t surface analysis provided, indicating proper' + &, ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me == 0) print *,'t surface analysis provided.' + endif + else + if (me == 0) then +! print *,'************************************************' + print *,'no tsf analysis available. climatology used' + endif + endif +! +! tsf0 +! + if(fntsfa(1:8).ne.' ' .and. lanom) then + call fixrda(lugb,fntsfa,kpdtsf,slmask, + & iy,im,id,ih,0.,tsfan0,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if(iret == 1) then + write(6,*) 't surface at ft=0 analysis read error' + call abort + elseif(iret == -1) then + if (me == 0) then + write(6,*) 'could not find t surface analysis at ft=0' + endif + call abort + else + print *,'t surface analysis at ft=0 found.' + endif + else + do i=1,len + tsfan0(i)=-999.9 + enddo + endif +! +! albedo +! + irtalb=0 + if(fnalba(1:8).ne.' ') then + do kk = 1, 4 + call fixrda(lugb,fnalba,kpdalb(kk),slmask, + & iy,im,id,ih,fh,albanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalb=iret + if(iret.eq.1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old albedo analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0 .and. kk .eq. 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no albedo analysis available. climatology used' + endif + endif +! +! vegetation fraction for albedo +! + irtalf=0 + if(fnalba(1:8).ne.' ') then + do kk = 1, 2 + call fixrda(lugb,fnalba,kpdalf(kk),slmask, + & iy,im,id,ih,fh,alfanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalf=iret + if(iret.eq.1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old albedo analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0 .and. kk .eq. 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegfalbedo analysis available. climatology used' + endif + endif +! +! soil wetness +! + irtwet=0 + irtsmc=0 + if(fnweta(1:8).ne.' ') then + call fixrda(lugb,fnweta,kpdwet,slmask, + & iy,im,id,ih,fh,wetanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtwet=iret + if(iret.eq.1) then + write(6,*) 'bucket wetness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old wetness analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'bucket wetness analysis provided.' + endif + elseif(fnsmca(1:8).ne.' ') then + call fixrda(lugb,fnsmca,kpdsmc,slmask, + & iy,im,id,ih,fh,smcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnsmca,kpdsmc,slmask, + & iy,im,id,ih,fh,smcanl(1,2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsmc=iret + if(iret.eq.1) then + write(6,*) 'layer soil wetness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old layer soil wetness analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'layer soil wetness analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no soil wetness analysis available. climatology used' + endif + endif +! +! read in snow depth/snow cover +! + irtscv=0 + if(fnsnoa(1:8).ne.' ') then + do i=1,len + scvanl(i)=0. + enddo +!cggg snow mods start +!cggg need to determine if the snow data is on the gaussian grid +!cggg or not. if gaussian, then data is a depth, not liq equiv +!cggg depth. if not gaussian, then data is from hua-lu's +!cggg program and is a liquid equiv. need to communicate +!cggg this to routine fixrda via the 3rd argument which is +!cggg the grib parameter id number. + call baopenr(lugb,fnsnoa,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fnsnoa) + print *,'error in opening file ',trim(fnsnoa) + call abort + endif + lugi=0 + lskip=-1 + jpds=-1 + jgds=-1 + kpds=jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + close(lugb) + if (iret .ne. 0) then + write(6,*) ' error reading header of file: ',trim(fnsnoa) + print *,'error reading header of file: ',trim(fnsnoa) + call abort + endif + if (kgds(1) == 4) then ! gaussian data is depth + call fixrda(lugb,fnsnoa,kpdsnd,slmask, + & iy,im,id,ih,fh,snoanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + snoanl=snoanl*100. ! convert from meters to liq. eq. + ! depth in mm using 10:1 ratio + else ! lat/lon data is liq equv. depth + call fixrda(lugb,fnsnoa,kpdsno,slmask, + & iy,im,id,ih,fh,snoanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +!cggg snow mods end + irtscv=iret + if(iret.eq.1) then + write(6,*) 'snow depth analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snow depth analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snow depth analysis provided.' + endif + irtsno=0 + elseif(fnscva(1:8).ne.' ') then + do i=1,len + snoanl(i)=0. + enddo + call fixrda(lugb,fnscva,kpdscv,slmask, + & iy,im,id,ih,fh,scvanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsno=iret + if(iret.eq.1) then + write(6,*) 'snow cover analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snow cover analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snow cover analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no snow/snocov analysis available. climatology used' + endif + endif +! +! sea ice mask +! + irtacn=0 + irtais=0 + if(fnacna(1:8).ne.' ') then + call fixrda(lugb,fnacna,kpdacn,slmask, + & iy,im,id,ih,fh,acnanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtacn=iret + if(iret.eq.1) then + write(6,*) 'ice concentration analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old ice concentration analysis provided', + & ' indicating proper file name is given' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'ice concentration analysis provided.' + endif + elseif(fnaisa(1:8).ne.' ') then + call fixrda(lugb,fnaisa,kpdais,slmask, + & iy,im,id,ih,fh,aisanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtais=iret + if(iret.eq.1) then + write(6,*) 'ice mask analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old ice-mask analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'ice mask analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no sea-ice analysis available. climatology used' + endif + endif +! +! surface roughness +! + irtzor=0 + if(fnzora(1:8).ne.' ') then + call fixrda(lugb,fnzora,kpdzor,slmask, + & iy,im,id,ih,fh,zoranl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtzor=iret + if(iret.eq.1) then + write(6,*) 'roughness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old roughness analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'roughness analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no srfc roughness analysis available. climatology used' + endif + endif +! +! deep soil temperature +! + irttg3=0 + irtstc=0 + if(fntg3a(1:8).ne.' ') then + call fixrda(lugb,fntg3a,kpdtg3,slmask, + & iy,im,id,ih,fh,tg3anl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irttg3=iret + if(iret.eq.1) then + write(6,*) 'deep soil tmp analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old deep soil temp analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'deep soil tmp analysis provided.' + endif + elseif(fnstca(1:8).ne.' ') then + call fixrda(lugb,fnstca,kpdstc,slmask, + & iy,im,id,ih,fh,stcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnstca,kpdstc,slmask, + & iy,im,id,ih,fh,stcanl(1,2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtstc=iret + if(iret.eq.1) then + write(6,*) 'layer soil tmp analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old deep soil temp analysis provided', + & 'iindicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'layer soil tmp analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no deep soil temp analy available. climatology used' + endif + endif +! +! vegetation cover +! + irtveg=0 + if(fnvega(1:8).ne.' ') then + call fixrda(lugb,fnvega,kpdveg,slmask, + & iy,im,id,ih,fh,veganl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtveg=iret + if(iret.eq.1) then + write(6,*) 'vegetation cover analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old vegetation cover analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'gegetation cover analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegetation cover anly available. climatology used' + endif + endif +! +! vegetation type +! + irtvet=0 + if(fnveta(1:8).ne.' ') then + call fixrda(lugb,fnveta,kpdvet,slmask, + & iy,im,id,ih,fh,vetanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvet=iret + if(iret.eq.1) then + write(6,*) 'vegetation type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old vegetation type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'vegetation type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegetation type anly available. climatology used' + endif + endif +! +! soil type +! + irtsot=0 + if(fnsota(1:8).ne.' ') then + call fixrda(lugb,fnsota,kpdsot,slmask, + & iy,im,id,ih,fh,sotanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsot=iret + if(iret.eq.1) then + write(6,*) 'soil type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old soil type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'soil type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no soil type anly available. climatology used' + endif + endif + +!clu [+120l]-------------------------------------------------------------- +! +! min vegetation cover +! + irtvmn=0 + if(fnvmna(1:8).ne.' ') then + call fixrda(lugb,fnvmna,kpdvmn,slmask, + & iy,im,id,ih,fh,vmnanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvmn=iret + if(iret.eq.1) then + write(6,*) 'shdmin analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old shdmin analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'shdmin analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no shdmin anly available. climatology used' + endif + endif + +! +! max vegetation cover +! + irtvmx=0 + if(fnvmxa(1:8).ne.' ') then + call fixrda(lugb,fnvmxa,kpdvmx,slmask, + & iy,im,id,ih,fh,vmxanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvmx=iret + if(iret.eq.1) then + write(6,*) 'shdmax analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old shdmax analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'shdmax analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no shdmax anly available. climatology used' + endif + endif + +! +! slope type +! + irtslp=0 + if(fnslpa(1:8).ne.' ') then + call fixrda(lugb,fnslpa,kpdslp,slmask, + & iy,im,id,ih,fh,slpanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtslp=iret + if(iret.eq.1) then + write(6,*) 'slope type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old slope type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'slope type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no slope type anly available. climatology used' + endif + endif + +! +! max snow albedo +! + irtabs=0 + if(fnabsa(1:8).ne.' ') then + call fixrda(lugb,fnabsa,kpdabs,slmask, + & iy,im,id,ih,fh,absanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtabs=iret + if(iret.eq.1) then + write(6,*) 'snoalb analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snoalb analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snoalb analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no snoalb anly available. climatology used' + endif + endif + +!clu ---------------------------------------------------------------------- +! + return + end + +!>\ingroup mod_sfcsub + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, + & vegfcs, vetfcs, sotfcs, alffcs, +!cwu [+1l] add ()fcs for sih, sic + & sihfcs,sicfcs, +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsfanl,wetanl,snoanl,zoranl,albanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,aisanl, + & veganl, vetanl, sotanl, alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & len,lsoil) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), + & zorfcs(len),albfcs(len,4),aisfcs(len), + & tg3fcs(len), + & cvfcs (len),cvbfcs(len),cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len),vegfcs(len), + & vetfcs(len),sotfcs(len),alffcs(len,2) +!cwu [+1l] add ()fcs for sih, sic + &, sihfcs(len),sicfcs(len) +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + write(6,*) ' this is a dead start run, tsfc over land is', + & ' set as lowest sigma level temperture if given.' + write(6,*) ' if not, set to climatological tsf over land is used' +! +! + do i=1,len + tsffcs(i) = tsfanl(i) ! tsf + albfcs(i,1) = albanl(i,1) ! albedo + albfcs(i,2) = albanl(i,2) ! albedo + albfcs(i,3) = albanl(i,3) ! albedo + albfcs(i,4) = albanl(i,4) ! albedo + wetfcs(i) = wetanl(i) ! soil wetness + snofcs(i) = snoanl(i) ! snow + aisfcs(i) = aisanl(i) ! seaice + slifcs(i) = slianl(i) ! land/sea/snow mask + zorfcs(i) = zoranl(i) ! surface roughness +! plrfcs(i) = plranl(i) ! maximum stomatal resistance + tg3fcs(i) = tg3anl(i) ! deep soil temperature + cnpfcs(i) = cnpanl(i) ! canopy water content + cvfcs(i) = cvanl(i) ! cv + cvbfcs(i) = cvbanl(i) ! cvb + cvtfcs(i) = cvtanl(i) ! cvt + vegfcs(i) = veganl(i) ! vegetation cover + vetfcs(i) = vetanl(i) ! vegetation type + sotfcs(i) = sotanl(i) ! soil type + alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo + alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo +!cwu [+2l] add sih, sic + sihfcs(i) = sihanl(i) ! sea ice thickness + sicfcs(i) = sicanl(i) ! sea ice concentration +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) ! min vegetation cover + vmxfcs(i) = vmxanl(i) ! max vegetation cover + slpfcs(i) = slpanl(i) ! slope type + absfcs(i) = absanl(i) ! max snow albedo + enddo +! + do j=1,lsoil + do i=1,len + smcfcs(i,j) = smcanl(i,j) ! layer soil wetness + stcfcs(i,j) = stcanl(i,j) ! soil temperature + enddo + enddo +! + return + end + +!>\ingroup mod_sfcsub + subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil,k + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), + & slianl(len) +! +! note that smfcs comes in with the original unit (cm?) (not grib file) +! + do i = 1, len + smcfcs(i,1) = (smcfcs(i,1)/150.) * .37 + .1 + enddo + do k = 2, lsoil + do i = 1, len + smcfcs(i,k) = smcfcs(i,1) + enddo + enddo + if(lsoil.gt.2) then + do k = 3, lsoil + do i = 1, len + stcfcs(i,k) = stcfcs(i,2) + enddo + enddo + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine rof01(aisfld,len,op,crit) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) aisfld(len),crit + character*2 op +! + if(op.eq.'ge') then + do i=1,len + if(aisfld(i).ge.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'gt') then + do i=1,len + if(aisfld(i).gt.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'le') then + do i=1,len + if(aisfld(i).le.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'lt') then + do i=1,len + if(aisfld(i).lt.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + else + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) rlapse,umask + real (kind=kind_io8) tsfc(len), orog(len), slmask(len) +! + do i=1,len + if(slmask(i).eq.umask) then + tsfc(i) = tsfc(i) - orog(i)*rlapse + endif + enddo + return + end + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, + & glacir,snwmax,snwmin,landice,len,snoanl, me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,me,len + logical, intent(in) :: landice + real (kind=kind_io8) sno,snwmax,snwmin +! + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), + & snoclm(len), snoanl(len), glacir(len) +! + if (me .eq. 0) write(6,*) 'snodpth' +! +! use surface temperature to get snow depth estimate +! + do i=1,len + sno = 0.0 +! +! over land +! + if(slianl(i).eq.1.) then + if(scvanl(i).eq.1.0) then + if(tsfanl(i).lt.243.0) then + sno = snwmax + elseif(tsfanl(i).lt.273.0) then + sno = snwmin+(snwmax-snwmin)*(273.0-tsfanl(i))/30.0 + else + sno = snwmin + endif + endif +! +! if glacial points has snow in climatology, set sno to snomax +! + if (.not.landice) then + if(glacir(i).eq.1.0) then + sno = snoclm(i) + if(sno.eq.0.) sno=snwmax + endif + endif + endif +! +! over sea ice +! +! snow over sea ice is cycled as of 01/01/94.....hua-lu pan +! + if(slianl(i).eq.2.0) then + sno=snoclm(i) + if(sno.eq.0.) sno=snwmax + endif +! + snoanl(i) = sno + enddo + return + end subroutine snodpth + +!>\ingroup mod_sfcsub + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, + & cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, + & vetfcs,sotfcs,alffcs, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,veganl, + & vetanl,sotanl,alfanl, + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & calfl,calfs, + & csihl,csihs,csicl,csics, + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvmn,irtvmx,irtslp,irtabs, + & irtvet,irtsot,irtalf, landice, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : veg_type_landice, soil_type_landice + implicit none + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, + & irtalb,irtsno,irttsf,irtwet,j + &, irtvmn,irtvmx,irtslp,irtabs + logical, intent(in) :: landice + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, + & cvets,calfs,deltsfc, + & csihl,csihs,csicl,csics, + & rsihl,rsihs,rsicl,rsics, + & qsihl,qsihs,qsicl,qsics + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns + &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss +! + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2) + &, sihfcs(len), sicfcs(len) + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),tsfan2(len), + & wetanl(len),snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2) + &, sihanl(len),sicanl(len) + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), + & cstcl(lsoil), cstcs(lsoil) + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), + & rstcl(lsoil), rstcs(lsoil) + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), + & qstcl(lsoil), qstcs(lsoil) + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, i1_t, i2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! +! coeeficients of blending forecast and interpolated clim +! (or analyzed) fields over sea or land(l) (not for clouds) +! 1.0 = use of forecast +! 0.0 = replace with interpolated analysis +! +! merging coefficients are defined by parameter statement in calling program +! and therefore they should not be modified in this program. +! + rtsfl = ctsfl + ralbl = calbl + ralfl = calfl + raisl = caisl + rsnol = csnol +!clu rsmcl = csmcl + rzorl = czorl + rvegl = cvegl + rvetl = cvetl + rsotl = csotl + rsihl = csihl + rsicl = csicl + rvmnl = cvmnl + rvmxl = cvmxl + rslpl = cslpl + rabsl = cabsl +! + rtsfs = ctsfs + ralbs = calbs + ralfs = calfs + raiss = caiss + rsnos = csnos +! rsmcs = csmcs + rzors = czors + rvegs = cvegs + rvets = cvets + rsots = csots + rsihs = csihs + rsics = csics + rvmns = cvmns + rvmxs = cvmxs + rslps = cslps + rabss = cabss +! + rcv = ccv + rcvb = ccvb + rcvt = ccvt + rcnp = ccnp +! + do k=1,lsoil + rsmcl(k) = csmcl(k) + rsmcs(k) = csmcs(k) + rstcl(k) = cstcl(k) + rstcs(k) = cstcs(k) + enddo + if (fh-deltsfc < -0.001 .and. irttsf == 1) then + rtsfs = 1.0 + rtsfl = 1.0 +! do k=1,lsoil +! rsmcl(k) = 1.0 +! rsmcs(k) = 1.0 +! rstcl(k) = 1.0 +! rstcs(k) = 1.0 +! enddo + endif +! +! if analysis file name is given but no matching analysis date found, +! use guess (these are flagged by irt???=1). +! + if(irttsf == -1) then + rtsfl = 1. + rtsfs = 1. + endif + if(irtalb == -1) then + ralbl = 1. + ralbs = 1. + ralfl = 1. + ralfs = 1. + endif + if(irtais == -1) then + raisl = 1. + raiss = 1. + endif + if(irtsno == -1 .or. irtscv == -1) then + rsnol = 1. + rsnos = 1. + endif + if(irtsmc == -1 .or. irtwet == -1) then +! rsmcl = 1. +! rsmcs = 1. + do k=1,lsoil + rsmcl(k) = 1. + rsmcs(k) = 1. + enddo + endif + if(irtstc.eq.-1) then + do k=1,lsoil + rstcl(k) = 1. + rstcs(k) = 1. + enddo + endif + if(irtzor == -1) then + rzorl = 1. + rzors = 1. + endif + if(irtveg == -1) then + rvegl = 1. + rvegs = 1. + endif + if(irtvet.eq.-1) then + rvetl = 1. + rvets = 1. + endif + if(irtsot == -1) then + rsotl = 1. + rsots = 1. + endif + + if(irtacn == -1) then + rsicl = 1. + rsics = 1. + endif + if(irtvmn == -1) then + rvmnl = 1. + rvmns = 1. + endif + if(irtvmx == -1) then + rvmxl = 1. + rvmxs = 1. + endif + if(irtslp == -1) then + rslpl = 1. + rslps = 1. + endif + if(irtabs == -1) then + rabsl = 1. + rabss = 1. + endif +! + if(raiss == 1. .or. irtacn == -1) then + if (me == 0) print *,'use forecast land-sea-ice mask' + do i = 1, len + aisanl(i) = aisfcs(i) + slianl(i) = slifcs(i) + enddo + endif +! + if (me == 0) then + write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl + 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) + write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs + 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',10f7.3) +! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl +! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets + endif +! + qtsfl = 1. - rtsfl + qalbl = 1. - ralbl + qalfl = 1. - ralfl + qaisl = 1. - raisl + qsnol = 1. - rsnol +! qsmcl = 1. - rsmcl + qzorl = 1. - rzorl + qvegl = 1. - rvegl + qvetl = 1. - rvetl + qsotl = 1. - rsotl + qsihl = 1. - rsihl + qsicl = 1. - rsicl + qvmnl = 1. - rvmnl + qvmxl = 1. - rvmxl + qslpl = 1. - rslpl + qabsl = 1. - rabsl +! + qtsfs = 1. - rtsfs + qalbs = 1. - ralbs + qalfs = 1. - ralfs + qaiss = 1. - raiss + qsnos = 1. - rsnos +! qsmcs = 1. - rsmcs + qzors = 1. - rzors + qvegs = 1. - rvegs + qvets = 1. - rvets + qsots = 1. - rsots + qsihs = 1. - rsihs + qsics = 1. - rsics + qvmns = 1. - rvmns + qvmxs = 1. - rvmxs + qslps = 1. - rslps + qabss = 1. - rabss +! + qcv = 1. - rcv + qcvb = 1. - rcvb + qcvt = 1. - rcvt + qcnp = 1. - rcnp +! + do k=1,lsoil + qsmcl(k) = 1. - rsmcl(k) + qsmcs(k) = 1. - rsmcs(k) + qstcl(k) = 1. - rstcl(k) + qstcs(k) = 1. - rstcs(k) + enddo +! +! merging +! + if(me .eq. 0) then + print *, 'dbgx-- csmcl:', (csmcl(k),k=1,lsoil) + print *, 'dbgx-- rsmcl:', (rsmcl(k),k=1,lsoil) + print *, 'dbgx-- csnol, csnos:',csnol,csnos + print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos + endif + +! print *, rtsfs, qtsfs, raiss , qaiss +! *, rsnos , qsnos, rzors , qzors, rvegs , qvegs +! *, rvets , qvets, rsots , qsots +! *, rcv, rcvb, rcvt, qcv, qcvb, qcvt +! *, ralbs, qalbs, ralfs, qalfs +! print *, rtsfl, qtsfl, raisl , qaisl +! *, rsnol , qsnol, rzorl , qzorl, rvegl , qvegl +! *, rvetl , qvetl, rsotl , qsotl +! *, ralbl, qalbl, ralfl, qalfl +! +! + len_thread_m = (len+num_threads-1) / num_threads + +!$omp parallel do private(i1_t,i2_t,it,i) + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets + sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots + else + vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl + sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl + endif + enddo + enddo +!$omp end parallel do +! +!$omp parallel do private(i1_t,i2_t,it,i,k) +! + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) +! + do i=i1_t,i2_t + if(slianl(i).eq.0.) then +!.... tsffc2 is the previous anomaly + today's climatology +! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) +! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs +! + tsfanl(i) = tsffcs(i)*rtsfs + tsfanl(i)*qtsfs +! albanl(i) = albfcs(i)*ralbs + albanl(i)*qalbs + aisanl(i) = aisfcs(i)*raiss + aisanl(i)*qaiss + snoanl(i) = snofcs(i)*rsnos + snoanl(i)*qsnos + + zoranl(i) = zorfcs(i)*rzors + zoranl(i)*qzors + veganl(i) = vegfcs(i)*rvegs + veganl(i)*qvegs + sihanl(i) = sihfcs(i)*rsihs + sihanl(i)*qsihs + sicanl(i) = sicfcs(i)*rsics + sicanl(i)*qsics + vmnanl(i) = vmnfcs(i)*rvmns + vmnanl(i)*qvmns + vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs + slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps + absanl(i) = absfcs(i)*rabss + absanl(i)*qabss + else + tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl +! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl + aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl + if(rsnol.ge.0)then + snoanl(i) = snofcs(i)*rsnol + snoanl(i)*qsnol + else ! envelope method + if(snoanl(i).ne.0)then + snoanl(i) = max(-snoanl(i)/rsnol, + & min(-snoanl(i)*rsnol, snofcs(i))) + endif + endif + zoranl(i) = zorfcs(i)*rzorl + zoranl(i)*qzorl + veganl(i) = vegfcs(i)*rvegl + veganl(i)*qvegl + vmnanl(i) = vmnfcs(i)*rvmnl + vmnanl(i)*qvmnl + vmxanl(i) = vmxfcs(i)*rvmxl + vmxanl(i)*qvmxl + slpanl(i) = slpfcs(i)*rslpl + slpanl(i)*qslpl + absanl(i) = absfcs(i)*rabsl + absanl(i)*qabsl + sihanl(i) = sihfcs(i)*rsihl + sihanl(i)*qsihl + sicanl(i) = sicfcs(i)*rsicl + sicanl(i)*qsicl + endif + + cnpanl(i) = cnpfcs(i)*rcnp + cnpanl(i)*qcnp +! +! snow over sea ice is cycled +! + if(slianl(i).eq.2.) then + snoanl(i) = snofcs(i) + endif +! + enddo + +! at landice points, set the soil type, slope type and +! greenness fields to flag values. + + if (landice) then + do i=i1_t,i2_t + if (nint(slianl(i)) == 1) then + if (nint(vetanl(i)) == veg_type_landice) then + sotanl(i) = soil_type_landice + veganl(i) = 0.0 + slpanl(i) = 9.0 + vmnanl(i) = 0.0 + vmxanl(i) = 0.0 + endif + end if ! if land + enddo + endif + + do i=i1_t,i2_t + cvanl(i) = cvfcs(i)*rcv + cvanl(i)*qcv + cvbanl(i) = cvbfcs(i)*rcvb + cvbanl(i)*qcvb + cvtanl(i) = cvtfcs(i)*rcvt + cvtanl(i)*qcvt + enddo +! + do k = 1, 4 + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + albanl(i,k) = albfcs(i,k)*ralbs + albanl(i,k)*qalbs + else + albanl(i,k) = albfcs(i,k)*ralbl + albanl(i,k)*qalbl + endif + enddo + enddo +! + do k = 1, 2 + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + alfanl(i,k) = alffcs(i,k)*ralfs + alfanl(i,k)*qalfs + else + alfanl(i,k) = alffcs(i,k)*ralfl + alfanl(i,k)*qalfl + endif + enddo + enddo +! + do k = 1, lsoil + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + smcanl(i,k) = smcfcs(i,k)*rsmcs(k) + smcanl(i,k)*qsmcs(k) + stcanl(i,k) = stcfcs(i,k)*rstcs(k) + stcanl(i,k)*qstcs(k) + else +! soil moisture not used at landice points, so +! don't bother merging it. also, for now don't allow nudging +! to raise subsurface temperature above freezing. + stcanl(i,k) = stcfcs(i,k)*rstcl(k) + stcanl(i,k)*qstcl(k) + if (landice .and. slianl(i) == 1.0 .and. + & nint(vetanl(i)) == veg_type_landice) then + smcanl(i,k) = 1.0 ! use value as flag + stcanl(i,k) = min(stcanl(i,k), 273.15) + else + smcanl(i,k) = smcfcs(i,k)*rsmcl(k) + smcanl(i,k)*qsmcl(k) + end if + endif + enddo + enddo +! + enddo ! end of threaded loop ................... +!$omp end parallel do + return + end subroutine merge + +!>\ingroup mod_sfcsub + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, +!cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & sihnew,sicnew,sihanl,sicanl, + & albanl,snoanl,zoranl,smcanl,stcanl, + & albsea,snosea,zorsea,smcsea,smcice, + & tsfmin,tsfice,albice,zorice,tgice, + & rla,rlo,me) +! + use machine , only : kind_io8,kind_io4 + implicit none + real (kind=kind_io8), parameter :: one=1.0 + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, + & smcice,tsfmin,zorsea,smcsea +!cwu [+1l] add sicnew,sihnew + &, sicnew,sihnew + integer i,me,kount1,kount2,k,len,lsoil + real (kind=kind_io8) slianl(len), slifcs(len), + & tsffcs(len),tsfanl(len) + real (kind=kind_io8) albanl(len,4), snoanl(len), zoranl(len) + real (kind=kind_io8) smcanl(len,lsoil), stcanl(len,lsoil) +!cwu [+1l] add sihanl & sicanl + real (kind=kind_io8) sihanl(len), sicanl(len) +! + real (kind=kind_io8) rla(len), rlo(len) +! + if (me .eq. 0) write(6,*) 'newice' +! + kount1 = 0 + kount2 = 0 + do i=1,len + if(slifcs(i).ne.slianl(i)) then + if(slifcs(i).eq.1..or.slianl(i).eq.1.) then + print *,'inconsistency in slifcs or slianl' + print 910,rla(i),rlo(i),slifcs(i),slianl(i), + & tsffcs(i),tsfanl(i) + 910 format(2x,'at lat=',f5.1,' lon=',f5.1,' slifcs=',f4.1, + & ' slimsk=',f4.1,' tsffcs=',f5.1,' set to tsfanl=',f5.1) + call abort + endif +! +! interpolated climatology indicates melted sea ice +! + if(slianl(i).eq.0..and.slifcs(i).eq.2.) then + tsfanl(i) = tsfmin + albanl(i,1) = albsea + albanl(i,2) = albsea + albanl(i,3) = albsea + albanl(i,4) = albsea + snoanl(i) = snosea + zoranl(i) = zorsea + do k = 1, lsoil + smcanl(i,k) = smcsea +!cwu [+1l] set stcanl to tgice (over sea-ice) + stcanl(i,k) = tgice + enddo +!cwu [+2l] set siganl and sicanl + sihanl(i) = 0. + sicanl(i) = 0. + kount1 = kount1 + 1 + endif +! +! interplated climatoloyg/analysis indicates new sea ice +! + if(slianl(i).eq.2..and.slifcs(i).eq.0.) then + tsfanl(i) = tsfice + albanl(i,1) = albice + albanl(i,2) = albice + albanl(i,3) = albice + albanl(i,4) = albice + snoanl(i) = 0. + zoranl(i) = zorice + do k = 1, lsoil + smcanl(i,k) = smcice + stcanl(i,k) = tgice + enddo +!cwu [+2l] add sihanl & sicanl + sihanl(i) = sihnew + sicanl(i) = min(one, max(sicnew,sicanl(i))) + kount2 = kount2 + 1 + endif + endif + enddo +! + if (me .eq. 0) then + if(kount1.gt.0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2.gt.0) then + write(6,*) 'sea ice formed. tsf,alb,zor are filled', + & ' at ',kount2,' points' + endif + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, + & landice,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer kount,i,len,me + logical, intent(in) :: landice + real (kind=kind_io8) per,snoval + real (kind=kind_io8) snoanl(len),slmask(len), + & aisanl(len),glacir(len) + if (me .eq. 0) then + write(6,*) ' ' + write(6,*) 'qc of snow' + endif + if (.not.landice) then + kount=0 + do i=1,len + if(glacir(i).ne.0..and.snoanl(i).eq.0.) then +! if(glacir(i).ne.0..and.snoanl(i).lt.snoval*0.5) then + snoanl(i) = snoval + kount = kount + 1 + endif + enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if (me .eq. 0) then + print *,'snow filled over glacier points at ',kount, + & ' points (',per,'percent)' + endif + endif + endif ! landice check + kount = 0 + do i=1,len + if(slmask(i).eq.0.and.aisanl(i).eq.0) then + snoanl(i) = 0. + kount = kount + 1 + endif + enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if (me .eq. 0) then + print *,'snow set to zero over open sea at ',kount, + & ' points (',per,'percent)' + endif + endif + return + end subroutine qcsnow + +!>\ingroup mod_sfcsub + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer kount1,kount,i,me,len + real (kind=kind_io8) per,aicsea,aicice,sllnd +! + real (kind=kind_io8) ais(len), glacir(len), + & amxice(len), slmask(len) + real (kind=kind_io8) rla(len), rlo(len) +! +! check sea-ice cover mask against land-sea mask +! + if (me .eq. 0) write(6,*) 'qc of sea ice' + kount = 0 + kount1 = 0 + do i=1,len + if(ais(i).ne.aicice.and.ais(i).ne.aicsea) then + print *,'sea ice mask not ',aicice,' or ',aicsea + print *,'ais(i),aicice,aicsea,rla(i),rlo(i,=', + & ais(i),aicice,aicsea,rla(i),rlo(i) + call abort + endif + if(slmask(i).eq.0..and.glacir(i).eq.1..and. +! if(slmask(i).eq.0..and.glacir(i).eq.2..and. + & ais(i).ne.1.) then + kount1 = kount1 + 1 + ais(i) = 1. + endif + if(slmask(i).eq.sllnd.and.ais(i).eq.aicice) then + kount = kount + 1 + ais(i) = aicsea + endif + enddo +! enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if(me .eq. 0) then + print *,' sea ice over land mask at ',kount,' points (',per, + & 'percent)' + endif + endif + per = float(kount1) / float(len)*100. + if(kount1.gt.0) then + if(me .eq. 0) then + print *,' sea ice set over glacier points over ocean at ', + & kount1,' points (',per,'percent)' + endif + endif +! kount=0 +! do j=1,jdim +! do i=1,idim +! if(amxice(i,j).ne.0..and.ais(i,j).eq.0.) then +! ais(i,j)=0. +! kount=kount+1 +! endif +! enddo +! enddo +! per=float(kount)/float(idim*jdim)*100. +! if(kount.gt.0) then +! print *,' sea ice exceeds maxice at ',kount,' points (',per, +! & 'percent)' +! endif +! +! remove isolated open ocean surrounded by sea ice and/or land +! +! remove isolated open ocean surrounded by sea ice and/or land +! +! ij = 0 +! do j=1,jdim +! do i=1,idim +! ij = ij + 1 +! ip = i + 1 +! im = i - 1 +! jp = j + 1 +! jm = j - 1 +! if(jp.gt.jdim) jp = jdim - 1 +! if(jm.lt.1) jm = 2 +! if(ip.gt.idim) ip = 1 +! if(im.lt.1) im = idim +! if(slmask(i,j).eq.0..and.ais(i,j).eq.0.) then +! if((slmask(ip,jp).eq.1..or.ais(ip,jp).eq.1.).and. +! & (slmask(i ,jp).eq.1..or.ais(i ,jp).eq.1.).and. +! & (slmask(im,jp).eq.1..or.ais(im,jp).eq.1.).and. +! & (slmask(ip,j ).eq.1..or.ais(ip,j ).eq.1.).and. +! & (slmask(im,j ).eq.1..or.ais(im,j ).eq.1.).and. +! & (slmask(ip,jm).eq.1..or.ais(ip,jm).eq.1.).and. +! & (slmask(i ,jm).eq.1..or.ais(i ,jm).eq.1.).and. +! & (slmask(im,jm).eq.1..or.ais(im,jm).eq.1.)) then +! ais(i,j) = 1. +! write(6,*) ' isolated open sea point surrounded by', +! & ' sea ice or land modified to sea ice', +! & ' at lat=',rla(i,j),' lon=',rlo(i,j) +! endif +! endif +! enddo +! enddo + return + end + +!>\ingroup mod_sfcsub + subroutine setlsi(slmask,aisfld,len,aicice,slifld) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) aicice + real (kind=kind_io8) slmask(len), slifld(len), aisfld(len) +! +! set surface condition indicator slimsk +! + do i=1,len + slifld(i) = slmask(i) +! if(aisfld(i).eq.aicice) slifld(i) = 2.0 + if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) + & slifld(i) = 2.0 + enddo + return + end +!>\ingroup mod_sfcsub + subroutine scale(fld,len,scl) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) fld(len),scl + do i=1,len + fld(i) = fld(i) * scl + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, + & rla,rlo,len,mode,percrit,lgchek,me) +! + use machine , only : kind_io8,kind_io4 + implicit none + real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, + & fldlmx,fldlmn,fldomx,fldjmn,percrit, + & fldsmx,fldsmn,epsfld + integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, + & ij,nprt,kmaxs,kmins,i,me,len,mode + parameter(mmprt=2) +! + character*8 ttl + logical iceflg(len) + real (kind=kind_io8) fld(len),slimsk(len),sno(len), + & rla(len), rlo(len) + integer iwk(len) + logical lgchek +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, i1_t, i2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! +! check against land-sea mask and ice cover mask +! + if(me .eq. 0) then +! print *,' ' + print *,'performing qc of ',ttl,' mode=',mode, + & '(0=count only, 1=replace)' + endif +! + len_thread_m = (len+num_threads-1) / num_threads + kmaxl = 0 + kminl = 0 + kmaxo = 0 + kmino = 0 + kmaxi = 0 + kmini = 0 + kmaxj = 0 + kminj = 0 + kmaxs = 0 + kmins = 0 +!$omp parallel do private(i1_t,i2_t,it,i) +!$omp+private(nprt,ij,iwk) +!$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) +!$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) +!$omp+shared(mode,epsfld) +!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) +!$omp+shared(fld,slimsk,sno,rla,rlo) + do it=1,num_threads ! start of threaded loop + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) +! +! +! +! lower bound check over bare land +! + if (fldlmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).lt.fldlmn-epsfld) then + kminl=kminl+1 + iwk(kminl) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kminl) + do i=1,nprt + ij = iwk(i) + print 8001,rla(ij),rlo(ij),fld(ij),fldlmn + 8001 format(' bare land min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) + enddo + endif + if (mode .eq. 1) then + do i=1,kminl + fld(iwk(i)) = fldlmn + enddo + endif + endif +! +! upper bound check over bare land +! + if (fldlmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).gt.fldlmx+epsfld) then + kmaxl=kmaxl+1 + iwk(kmaxl) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxl) + do i=1,nprt + ij = iwk(i) + print 8002,rla(ij),rlo(ij),fld(ij),fldlmx + 8002 format(' bare land max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxl + fld(iwk(i)) = fldlmx + enddo + endif + endif +! +! lower bound check over snow covered land +! + if (fldsmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).lt.fldsmn-epsfld) then + kmins=kmins+1 + iwk(kmins) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmins) + do i=1,nprt + ij = iwk(i) + print 8003,rla(ij),rlo(ij),fld(ij),fldsmn + 8003 format(' sno covrd land min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmins + fld(iwk(i)) = fldsmn + enddo + endif + endif +! +! upper bound check over snow covered land +! + if (fldsmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).gt.fldsmx+epsfld) then + kmaxs=kmaxs+1 + iwk(kmaxs) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxs) + do i=1,nprt + ij = iwk(i) + print 8004,rla(ij),rlo(ij),fld(ij),fldsmx + 8004 format(' snow land max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxs + fld(iwk(i)) = fldsmx + enddo + endif + endif +! +! lower bound check over open ocean +! + if (fldomn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.0..and. + & fld(i).lt.fldomn-epsfld) then + kmino=kmino+1 + iwk(kmino) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmino) + do i=1,nprt + ij = iwk(i) + print 8005,rla(ij),rlo(ij),fld(ij),fldomn + 8005 format(' open ocean min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmino + fld(iwk(i)) = fldomn + enddo + endif + endif +! +! upper bound check over open ocean +! + if (fldomx .ne. 999.0) then + do i=i1_t,i2_t + if(fldomx.ne.999..and.slimsk(i).eq.0..and. + & fld(i).gt.fldomx+epsfld) then + kmaxo=kmaxo+1 + iwk(kmaxo) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxo) + do i=1,nprt + ij = iwk(i) + print 8006,rla(ij),rlo(ij),fld(ij),fldomx + 8006 format(' open ocean max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxo + fld(iwk(i)) = fldomx + enddo + endif + endif +! +! lower bound check over sea ice without snow +! + if (fldimn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).lt.fldimn-epsfld) then + kmini=kmini+1 + iwk(kmini) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmini) + do i=1,nprt + ij = iwk(i) + print 8007,rla(ij),rlo(ij),fld(ij),fldimn + 8007 format(' seaice no snow min. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmini + fld(iwk(i)) = fldimn + enddo + endif + endif +! +! upper bound check over sea ice without snow +! + if (fldimx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then +! & fld(i).gt.fldimx+epsfld) then + kmaxi=kmaxi+1 + iwk(kmaxi) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxi) + do i=1,nprt + ij = iwk(i) + print 8008,rla(ij),rlo(ij),fld(ij),fldimx + 8008 format(' seaice no snow max. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxi + fld(iwk(i)) = fldimx + enddo + endif + endif +! +! lower bound check over sea ice with snow +! + if (fldjmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).lt.fldjmn-epsfld) then + kminj=kminj+1 + iwk(kminj) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kminj) + do i=1,nprt + ij = iwk(i) + print 8009,rla(ij),rlo(ij),fld(ij),fldjmn + 8009 format(' sea ice snow min. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kminj + fld(iwk(i)) = fldjmn + enddo + endif + endif +! +! upper bound check over sea ice with snow +! + if (fldjmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then +! & fld(i).gt.fldjmx+epsfld) then + kmaxj=kmaxj+1 + iwk(kmaxj) = i + endif + enddo + if(me == 0 .and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxj) + do i=1,nprt + ij = iwk(i) + print 8010,rla(ij),rlo(ij),fld(ij),fldjmx + 8010 format(' seaice snow max check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxj + fld(iwk(i)) = fldjmx + enddo + endif + endif + enddo ! end of threaded loop +!$omp end parallel do +! +! print results +! + if(me .eq. 0) then +! write(6,*) 'summary of qc' + permax=0. + if(kminl.gt.0) then + per=float(kminl)/float(len)*100. + print 9001,fldlmn,kminl,per + 9001 format(' bare land min check. modified to ',f8.1, + & ' at ',i5,' points ',f8.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxl.gt.0) then + per=float(kmaxl)/float(len)*100. + print 9002,fldlmx,kmaxl,per + 9002 format(' bare land max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmino.gt.0) then + per=float(kmino)/float(len)*100. + print 9003,fldomn,kmino,per + 9003 format(' open ocean min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxo.gt.0) then + per=float(kmaxo)/float(len)*100. + print 9004,fldomx,kmaxo,per + 9004 format(' open sea max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmins.gt.0) then + per=float(kmins)/float(len)*100. + print 9009,fldsmn,kmins,per + 9009 format(' snow covered land min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxs.gt.0) then + per=float(kmaxs)/float(len)*100. + print 9010,fldsmx,kmaxs,per + 9010 format(' snow covered land max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmini.gt.0) then + per=float(kmini)/float(len)*100. + print 9005,fldimn,kmini,per + 9005 format(' bare ice min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxi.gt.0) then + per=float(kmaxi)/float(len)*100. + print 9006,fldimx,kmaxi,per + 9006 format(' bare ice max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kminj.gt.0) then + per=float(kminj)/float(len)*100. + print 9007,fldjmn,kminj,per + 9007 format(' snow covered ice min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxj.gt.0) then + per=float(kmaxj)/float(len)*100. + print 9008,fldjmx,kmaxj,per + 9008 format(' snow covered ice max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif +! commented on 06/30/99 -- moorthi +! if(lgchek) then +! if(permax.gt.percrit) then +! write(6,*) ' too many bad points. aborting ....' +! call abort +! endif +! endif +! + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine setzro(fld,eps,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) fld(len),eps + do i=1,len + if(abs(fld(i)).lt.eps) fld(i) = 0. + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine getscv(snofld,scvfld,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) snofld(len),scvfld(len) +! + do i=1,len + scvfld(i) = 0. + if(snofld(i).gt.0.) scvfld(i) = 1. + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine getstc(tsffld,tg3fld,slifld,len,lsoil,stcfld,tsfimx) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer k,i,len,lsoil + real (kind=kind_io8) factor,tsfimx + real (kind=kind_io8) tsffld(len), tg3fld(len), slifld(len) + real (kind=kind_io8) stcfld(len,lsoil) +! +! layer soil temperature +! + do k = 1, lsoil + do i = 1, len + if(slifld(i).eq.1.0) then + factor = ((k-1) * 2 + 1) / (2. * lsoil) + stcfld(i,k) = factor*tg3fld(i)+(1.-factor)*tsffld(i) + elseif(slifld(i).eq.2.0) then + factor = ((k-1) * 2 + 1) / (2. * lsoil) + stcfld(i,k) = factor*tsfimx+(1.-factor)*tsffld(i) + else + stcfld(i,k) = tg3fld(i) + endif + enddo + enddo + if(lsoil.gt.2) then + do k = 3, lsoil + do i = 1, len + stcfld(i,k) = stcfld(i,2) + enddo + enddo + endif + return + end + +!>\ingroup mod_sfcsub +!! This subroutine calculates layer soil wetness. + subroutine getsmc(wetfld,len,lsoil,smcfld,me) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer k,i,len,lsoil,me + real (kind=kind_io8) wetfld(len), smcfld(len,lsoil) +! + if (me .eq. 0) write(6,*) 'getsmc' +! +! layer soil wetness +! + do k = 1, lsoil + do i = 1, len + smcfld(i,k) = (wetfld(i)*1000./150.)*.37 + .1 + enddo + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, + & tsfimx) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len,lsoil + real (kind=kind_io8) tsfimx + real (kind=kind_io8) sig1t(len), slianl(len), tg3anl(len) + real (kind=kind_io8) tsfanl(len), stcanl(len,lsoil) +! +! soil temperature +! + if(sig1t(1).gt.0.) then + do i=1,len + if(slianl(i).ne.0.) then + tsfanl(i) = sig1t(i) + endif + enddo + endif + call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) +! + return + end + +!>\ingroup mod_sfcsub + subroutine snosfc(snoanl,tsfanl,tsfsmx,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer kount,i,len,me + real (kind=kind_io8) per,tsfsmx + real (kind=kind_io8) snoanl(len), tsfanl(len) +! + if (me .eq. 0) write(6,*) 'set snow temp to tsfsmx if greater' + kount=0 + do i=1,len + if(snoanl(i).gt.0.) then + if(tsfanl(i).gt.tsfsmx) tsfanl(i)=tsfsmx + kount = kount + 1 + endif + enddo + if(kount.gt.0) then + if(me .eq. 0) then + per=float(kount)/float(len)*100. + write(6,*) 'snow sfc. tsf set to ',tsfsmx,' at ', + & kount, ' points ',per,'percent' + endif + endif + return + end + +!>\ingroup mod_sfcsub + subroutine albocn(albclm,slmask,albomx,len) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) albomx + real (kind=kind_io8) albclm(len,4), slmask(len) + do i=1,len + if(slmask(i).eq.0) then + albclm(i,1) = albomx + albclm(i,2) = albomx + albclm(i,3) = albomx + albclm(i,4) = albomx + endif + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine qcmxice(glacir,amxice,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,kount,len,me + real (kind=kind_io8) glacir(len),amxice(len),per + if (me .eq. 0) write(6,*) 'qc of maximum ice extent' + kount=0 + do i=1,len + if(glacir(i).eq.1..and.amxice(i).eq.0.) then + amxice(i) = 0. + kount = kount + 1 + endif + enddo + if(kount.gt.0) then + per = float(kount) / float(len)*100. + if(me .eq. 0) write(6,*) ' max ice limit less than glacier' + &, ' coverage at ', kount, ' points ',per,'percent' + endif + return + end + +!>\ingroup mod_sfcsub + subroutine qcsli(slianl,slifcs,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,kount,len,me + real (kind=kind_io8) slianl(len), slifcs(len),per + if (me .eq. 0) then + write(6,*) ' ' + write(6,*) 'qcsli' + endif + kount=0 + do i=1,len + if(slianl(i).eq.1..and.slifcs(i).eq.0.) then + kount = kount + 1 + slifcs(i) = 1. + endif + if(slianl(i).eq.0..and.slifcs(i).eq.1.) then + kount = kount + 1 + slifcs(i) = 0. + endif + if(slianl(i).eq.2..and.slifcs(i).eq.1.) then + kount = kount + 1 + slifcs(i) = 0. + endif + if(slianl(i).eq.1..and.slifcs(i).eq.2.) then + kount = kount + 1 + slifcs(i) = 1. + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if(me .eq. 0) then + write(6,*) ' inconsistency of slmask between forecast and', + & ' analysis corrected at ',kount, ' points ',per, + & 'percent' + endif + endif + return + end +! subroutine nntprt(data,imax,fact) +! real (kind=kind_io8) data(imax) +! ilast=0 +! i1=1 +! i2=80 +!1112 continue +! if(i2.ge.imax) then +! ilast=1 +! i2=imax +! endif +! write(6,*) ' ' +! do j=1,jmax +! write(6,1111) (nint(data(imax*(j-1)+i)*fact),i=i1,i2) +! enddo +! if(ilast.eq.1) return +! i1=i1+80 +! i2=i1+79 +! if(i2.ge.imax) then +! ilast=1 +! i2=imax +! endif +! go to 1112 +!1111 format(80i1) +! return +! end + +!>\ingroup mod_sfcsub + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, + & zoranl,smcanl, + & smcclm,tsfsmx,albomx,zoromx, me) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer kount,me,k,i,lsoil,len + real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx + real (kind=kind_io8) tsffcs(len), snofcs(len) + real (kind=kind_io8) snoanl(len), aisanl(len), + & slianl(len), zoranl(len), + & tsfanl(len), albanl(len,4), + & smcanl(len,lsoil) + real (kind=kind_io8) smcclm(len,lsoil) +! + if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' +! +! qc of snow analysis +! +! questionable snow cover +! + kount = 0 + do i=1,len + if(slianl(i).gt.0..and. + & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then + kount = kount + 1 + snoanl(i) = 0. + tsfanl(i) = tsffcs(i) + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if (me .eq. 0) then + write(6,*) ' guess surface temp .gt. ',qctsfs, + & ' but snow analysis indicates snow cover' + write(6,*) ' snow analysis set to zero', + & ' at ',kount, ' points ',per,'percent' + endif + endif +! +! questionable no snow cover +! + kount = 0 + do i=1,len + if(slianl(i).gt.0..and. + & snofcs(i).gt.qcsnos.and.snoanl(i).lt.0.) then + kount = kount + 1 + snoanl(i) = snofcs(i) + tsfanl(i) = tsffcs(i) + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if (me .eq. 0) then + write(6,*) ' guess snow depth .gt. ',qcsnos, + & ' but snow analysis indicates no snow cover' + write(6,*) ' snow analysis set to guess value', + & ' at ',kount, ' points ',per,'percent' + endif + endif +! +! questionable sea ice cover ! this qc is disable to correct error in +! surface temparature over observed sea ice points +! +! kount = 0 +! do i=1,len +! if(slianl(i).eq.2..and. +! & tsffcs(i).gt.qctsfi.and.aisanl(i).eq.1.) then +! kount = kount + 1 +! aisanl(i) = 0. +! slianl(i) = 0. +! tsfanl(i) = tsffcs(i) +! snoanl(i) = 0. +! zoranl(i) = zoromx +! albanl(i,1) = albomx +! albanl(i,2) = albomx +! albanl(i,3) = albomx +! albanl(i,4) = albomx +! do k=1,lsoil +! smcanl(i,k) = smcclm(i,k) +! enddo +! endif +! enddo +! if(kount.gt.0) then +! per=float(kount)/float(len)*100. +! if (me .eq. 0) then +! write(6,*) ' guess surface temp .gt. ',qctsfi, +! & ' but sea-ice analysis indicates sea-ice' +! write(6,*) ' sea-ice analysis set to zero', +! & ' at ',kount, ' points ',per,'percent' +! endif +! endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, + & data,imax,jmax,rlnout,rltout,lmask,rslmsk + &, gaus,blno, blto, kgds1, kpds4, lbms) + use machine , only : kind_io8,kind_io4 + use sfccyc_module + implicit none + real (kind=kind_io8) blno,blto,wlon,rnlat,crit,data_max + integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla + integer, intent(in) :: kpds4 + logical*1, intent(in) :: lbms(imax,jmax) + real*4 :: dummy(imax,jmax) + + real (kind=kind_io8) slmask(igaul,jgaul) + real (kind=kind_io8) data(imax,jmax),rslmsk(imax,jmax) + &, rlnout(imax), rltout(jmax) + real (kind=kind_io8) a(jmax), w(jmax), radi, dlat, dlon + logical lmask, gaus +! +! set the longitude and latitudes for the grib file +! + if (kgds1 .eq. 4) then ! grib file on gaussian grid + kspla=4 + call splat(kspla, jmax, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do j=1,jmax + rltout(j) = acos(a(j)) * radi + enddo +! + if (rnlat .gt. 0.0) then + do j=1,jmax + rltout(j) = 90. - rltout(j) + enddo + else + do j=1,jmax + rltout(j) = -90. + rltout(j) + enddo + endif + elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid + dlat = -(rnlat+rnlat) / float(jmax-1) + do j=1,jmax + rltout(j) = rnlat + (j-1) * dlat + enddo + else ! grib file on some other grid + call abort + endif + dlon = 360.0 / imax + do i=1,imax + rlnout(i) = wlon + (i-1)*dlon + enddo +! +! + ijmax = imax*jmax + rslmsk = 0. +! +! surface temperature +! + if(kpds5.eq.kpdtsf) then +! lmask=.false. + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! +! bucket soil wetness +! + elseif(kpds5.eq.kpdwet) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'wet rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! snow depth +! + elseif(kpds5.eq.kpdsnd) then + if(kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask=.true. + else + lmask=.false. + end if +! +! snow liq equivalent depth +! + elseif(kpds5.eq.kpdsno) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'sno rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! soil moisture +! + elseif(kpds5.eq.kpdsmc) then + if(kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask=.true. + else + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. + endif +! +! surface roughness +! + elseif(kpds5.eq.kpdzor) then + do j=1,jmax + do i=1,imax + rslmsk(i,j)=data(i,j) + enddo + enddo + crit=9.9 + call rof01(rslmsk,ijmax,'lt',crit) + lmask=.true. +! write(6,*) 'zor rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! albedo +! +! elseif(kpds5.eq.kpdalb) then +! do j=1,jmax +! do i=1,imax +! rslmsk(i,j)=data(i,j) +! enddo +! enddo +! crit=99. +! call rof01(rslmsk,ijmax,'lt',crit) +! lmask=.true. +! write(6,*) 'alb rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! albedo +! +!cbosu new snowfree albedo database has bitmap, use it. + elseif(kpds5.eq.kpdalb(1)) then + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(2)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(3)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(4)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if +! +! vegetation fraction for albedo +! + elseif(kpds5.eq.kpdalf(1)) then +! rslmsk=data +! crit=0. +! call rof01(rslmsk,ijmax,'gt',crit) +! lmask=.true. + lmask=.false. + elseif(kpds5.eq.kpdalf(2)) then +! rslmsk=data +! crit=0. +! call rof01(rslmsk,ijmax,'gt',crit) +! lmask=.true. + lmask=.false. +! +! sea ice +! + elseif(kpds5.eq.kpdais) then + lmask=.false. +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! + data_max = 0.0 + do j=1,jmax + do i=1,imax + rslmsk(i,j) = data(i,j) + data_max= max(data_max,data(i,j)) + enddo + enddo + crit=1.0 + if (data_max .gt. crit) then + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. + else + lmask=.false. + endif +! write(6,*) 'acn rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! deep soil temperature +! + elseif(kpds5.eq.kpdtg3) then + lmask=.false. +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! lmask=.true. +! +! plant resistance +! +! elseif(kpds5.eq.kpdplr) then +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! lmask=.true. +! +! write(6,*) 'plr rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! glacier points +! + elseif(kpds5.eq.kpdgla) then + lmask=.false. +! +! max ice extent +! + elseif(kpds5.eq.kpdmxi) then + lmask=.false. +! +! snow cover +! + elseif(kpds5.eq.kpdscv) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'scv rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! sea ice concentration +! + elseif(kpds5.eq.kpdacn) then + lmask=.false. + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'acn rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! vegetation cover +! + elseif(kpds5.eq.kpdveg) then +!cggg + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction + end if + enddo + enddo + lmask = .true. + else ! no bitmap, set mask the old way. + + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. + + end if +! +! soil type +! + elseif(kpds5.eq.kpdsot) then + + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo +! soil type is zero over water, use this to get a bitmap. + else + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + endif + lmask=.true. +! +! vegetation type +! + elseif(kpds5.eq.kpdvet) then + + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo +! veg type is zero over water, use this to get a bitmap. + else + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + endif + lmask=.true. +! +! these are for four new data type added by clu -- not sure its correct! +! + elseif(kpds5.eq.kpdvmn) then +! +!cggg greenness is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! + elseif(kpds5.eq.kpdvmx) then +! +!cggg greenness is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! + elseif(kpds5.eq.kpdslp) then +! +!cggg slope type is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! +!cbosu new maximum snow albedo database has bitmap + elseif(kpds5.eq.kpdabs) then + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has zero over water + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. + end if + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, + & wlon,rnlat,rlnout,rltout,gaus,blno, blto) + use machine , only : kind_io8,kind_io4 + implicit none + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, + & j,iret + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, + & rnlat,dxout,dphi,dlat,facns,tem,blno, + & blto +! +! interpolation from lat/lon grid to other lat/lon grid +! + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) + &, rlnout(imxout), rltout(jmxout) + logical gaus +! + real, allocatable :: gaul(:) + real (kind=kind_io8) ddx(imxout),ddy(jmxout) + integer iindx1(imxout), iindx2(imxout), + & jindx1(jmxout), jindx2(jmxout) + integer jmxsav,n,kspla + data jmxsav/0/ + save jmxsav, gaul, dlati + real (kind=kind_io8) radi + real (kind=kind_io8) a(jmxin), w(jmxin) +! +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, j1_t, j2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! + if (jmxin .ne. jmxsav) then + if (jmxsav .gt. 0) deallocate (gaul, stat=iret) + allocate (gaul(jmxin)) + jmxsav = jmxin + if (gaus) then +cjfe call gaulat(gaul,jmxin) +cjfe +! + kspla=4 + call splat(kspla, jmxin, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do n=1,jmxin + gaul(n) = acos(a(n)) * radi + enddo +cjfe + do j=1,jmxin + gaul(j) = 90. - gaul(j) + enddo + else + dlat = -2*blto / float(jmxin-1) + dlati = 1 / dlat + do j=1,jmxin + gaul(j) = blto + (j-1) * dlat + enddo + endif + endif +! +! + dxin = 360. / float(imxin ) +! + do i=1,imxout + alamd = rlnout(i) + i1 = floor((alamd-blno)/dxin) + 1 + ddx(i) = (alamd-blno)/dxin-(i1-1) + iindx1(i) = modulo(i1-1,imxin) + 1 + iindx2(i) = modulo(i1 ,imxin) + 1 + enddo +! +! + len_thread_m = (jmxout+num_threads-1) / num_threads +! + if (gaus) then +! +!$omp parallel do private(j1_t,j2_t,it,j1,j2,jj) +!$omp+private(aphi) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + j2=1 + do 40 j=j1_t,j2_t + aphi=rltout(j) + do 50 jj=1,jmxin + if(aphi.lt.gaul(jj)) go to 50 + j2=jj + go to 42 + 50 continue + 42 continue + if(j2.gt.2) go to 43 + j1=1 + j2=2 + go to 44 + 43 continue + if(j2.le.jmxin) go to 45 + j1=jmxin-1 + j2=jmxin + go to 44 + 45 continue + j1=j2-1 + 44 continue + jindx1(j)=j1 + jindx2(j)=j2 + ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) + 40 continue + enddo ! end of threaded loop ................... +!$omp end parallel do +! + else +!$omp parallel do private(j1_t,j2_t,it,j1,j2,jtem) +!$omp+private(aphi) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy,dlati,blto) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + j2=1 + do 400 j=j1_t,j2_t + aphi=rltout(j) + jtem = (aphi - blto) * dlati + 1 + if (jtem .ge. 1 .and. jtem .lt. jmxin) then + j1 = jtem + j2 = j1 + 1 + ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) + elseif (jtem .eq. jmxin) then + j1 = jmxin + j2 = jmxin + ddy(j)=1.0 + else + j1 = 1 + j2 = 1 + ddy(j)=1.0 + endif +! + jindx1(j) = j1 + jindx2(j) = j2 + 400 continue + enddo ! end of threaded loop ................... +!$omp end parallel do + endif +! +! write(6,*) 'ga2la' +! write(6,*) 'iindx1' +! write(6,*) (iindx1(n),n=1,imxout) +! write(6,*) 'iindx2' +! write(6,*) (iindx2(n),n=1,imxout) +! write(6,*) 'jindx1' +! write(6,*) (jindx1(n),n=1,jmxout) +! write(6,*) 'jindx2' +! write(6,*) (jindx2(n),n=1,jmxout) +! write(6,*) 'ddy' +! write(6,*) (ddy(n),n=1,jmxout) +! write(6,*) 'ddx' +! write(6,*) (ddx(n),n=1,jmxout) +! +! +!$omp parallel do private(j1_t,j2_t,it,i,i1,i2) +!$omp+private(j,j1,j2,x,y) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(imxout,iindx1,jindx1,ddx,ddy,gauin,regout) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + do j=j1_t,j2_t + y = ddy(j) + j1 = jindx1(j) + j2 = jindx2(j) + do i=1,imxout + x = ddx(i) + i1 = iindx1(i) + i2 = iindx2(i) + regout(i,j) = (1.-x)*((1.-y)*gauin(i1,j1) + y*gauin(i1,j2)) + & + x *((1.-y)*gauin(i2,j1) + y*gauin(i2,j2)) + enddo + enddo + enddo ! end of threaded loop ................... +!$omp end parallel do +! + sum1 = 0. + sum2 = 0. + do i=1,imxin + sum1 = sum1 + gauin(i,1) + sum2 = sum2 + gauin(i,jmxin) + enddo + sum1 = sum1 / float(imxin) + sum2 = sum2 / float(imxin) +! + if (gaus) then + if (rnlat .gt. 0.0) then + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + else + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + endif + else + if (blto .lt. 0.0) then + if (rnlat .gt. 0.0) then + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + else + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + endif + else + if (rnlat .lt. 0.0) then + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + else + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + endif + endif + endif +! + return + end + +!>\ingroup mod_sfcsub + subroutine landtyp(vegtype,soiltype,slptype,slmask,len) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) + +, slptype(len) +! +! make sure that the soil type and veg type are non-zero over land +! + do i = 1, len + if (slmask(i) .eq. 1) then + if (vegtype(i) .eq. 0.) vegtype(i) = 7 + if (soiltype(i) .eq. 0.) soiltype(i) = 2 + if (slptype(i) .eq. 0.) slptype(i) = 1 + endif + enddo + return + +!>\ingroup mod_sfcsub + end subroutine landtyp + subroutine gaulat(gaul,k) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer n,k + real (kind=kind_io8) radi + real (kind=kind_io8) a(k), w(k), gaul(k) +! + call splat(4, k, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do n=1,k + gaul(n) = acos(a(n)) * radi + enddo +! +! print *,'gaussian lat (deg) for jmax=',k +! print *,(gaul(n),n=1,k) +! + return + 70 write(6,6000) + 6000 format(//5x,'error in gauaw'//) + stop + end +!----------------------------------------------------------------------- +!>\ingroup mod_sfcsub +!! The subroutine conducts time interpolation of anomalies, +!! and add initial anomaly to date interpolated climatology. + subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) tsfanl(len), tsfan0(len), + & tsfclm(len), tsfcl0(len) +! +! time interpolation of anomalies +! add initial anomaly to date interpolated climatology +! + write(6,*) 'anomint' + do i=1,len + tsfanl(i) = tsfan0(i) - tsfcl0(i) + tsfclm(i) + enddo + return + end + +!>\ingroup mod_sfcsub + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc, + & fnvmnc,fnvmxc,fnslpc,fnabsc, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, + & vetclm,sotclm,alfclm, + & vmnclm,vmxclm,slpclm,absclm, + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & deltsfc, lanom + &, imsk, jmsk, slmskh, outlat, outlon + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb + &, tile_num_ch, i_index, j_index) +! + use machine , only : kind_io8,kind_io4 + implicit none + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: i_index(len), j_index(len) + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, + & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 + real (kind=kind_io8) wei1y,wei2y + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb + &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat + integer kpdalb(4), kpdalf(2) +! + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc,fnalbc2 + &, fnvmnc,fnvmxc,fnslpc,fnabsc + real (kind=kind_io8) tsfclm(len),tsfcl2(len), + & wetclm(len),snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len),acnclm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) + &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) + real (kind=kind_io8) slmskh(imsk,jmsk) + real (kind=kind_io8) outlat(len), outlon(len) +! + real (kind=kind_io8) slmask(len), tsfcl0(len) + real (kind=kind_io8), allocatable :: slmask_noice(:) +! + logical lanom, gaus, first +! +! set z0 based on sib vegetation type + real (kind=kind_io8) z0_sib(13) + data z0_sib /2.653, 0.826, 0.563, 1.089, 0.854, 0.856, + & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125, + & 0.011 / +! set z0 based on igbp vegetation type + real (kind=kind_io8) z0_igbp_min(20), z0_igbp_max(20) + real (kind=kind_io8) z0_season(12) + data z0_igbp_min /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, + & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, + & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, + & 0.050, 0.030/ + data z0_igbp_max /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, + & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, + & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, + & 0.050, 0.030/ +! +! dayhf : julian day of the middle of each month +! + real (kind=kind_io8) dayhf(13) + data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, + & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ +! + real (kind=kind_io8) fha(5) + real(4) fha4(5) + integer w3kindreal,w3kindint + integer ida(8),jda(8),ivtyp, kpd7 +! + real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:), + & zor(:,:),wet(:,:), + & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:), + & tg3(:), alb(:,:,:), alf(:,:), + & vet(:), sot(:), tsf2(:), + & veg(:,:), stc(:,:,:) + &, vmn(:), vmx(:), slp(:), absm(:) +! + integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2 + data first/.true./ + data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/ +! + save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, + & alb, alf, vet, sot, tsf2, veg, stc, + & vmn, vmx, slp, absm, + & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, + & landice_cat +! + logical lprnt +! + do i=1,len + tsfclm(i) = 0.0 + tsfcl2(i) = 0.0 + snoclm(i) = 0.0 + wetclm(i) = 0.0 + zorclm(i) = 0.0 + aisclm(i) = 0.0 + tg3clm(i) = 0.0 + acnclm(i) = 0.0 + cvclm(i) = 0.0 + cvbclm(i) = 0.0 + cvtclm(i) = 0.0 + cnpclm(i) = 0.0 + sliclm(i) = 0.0 + scvclm(i) = 0.0 + vmnclm(i) = 0.0 + vmxclm(i) = 0.0 + slpclm(i) = 0.0 + absclm(i) = 0.0 + enddo + do k=1,lsoil + do i=1,len + smcclm(i,k) = 0.0 + stcclm(i,k) = 0.0 + enddo + enddo + do k=1,4 + do i=1,len + albclm(i,k) = 0.0 + enddo + enddo + do k=1,2 + do i=1,len + alfclm(i,k) = 0.0 + enddo + enddo +! + iret = 0 + monend = 9999 +! + if (first) then +! +! allocate variables to be saved +! + allocate (tsf(len,2), sno(len,2), zor(len,2), + & wet(len,2), ais(len,2), acn(len,2), + & scv(len,2), smc(len,lsoil,2), + & tg3(len), alb(len,4,2), alf(len,2), + & vet(len), sot(len), tsf2(len), +!clu [+1l] add vmn, vmx, slp, abs + & vmn(len), vmx(len), slp(len), absm(len), + & veg(len,2), stc(len,lsoil,2)) +! +! get tsf climatology for the begining of the forecast +! + if (fh .gt. 0.0) then +!cbosu + if (me == 0) print*,'bosu fh gt 0' + + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha=0 + ida=0 + jda=0 +! fha(2)=nint(fh) + ida(1)=iy + ida(2)=im + ida(3)=id + ida(5)=ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal == 4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy=jda(1) + jm=jda(2) + jd=jda(3) + jh=jda(5) + if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh', + & jy,jm,jd,jh + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday=jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. +! + if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! +! for monthly mean climatology +! + monend = 12 + do mm=1,monend + mmm=mm + mmp=mm+1 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + mon1=mmm + mon2=mmp + go to 10 + endif + enddo + print *,'wrong rjday',rjday + call abort + 10 continue + wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) + wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if(mon2.eq.13) mon2=1 + if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m +! +! read monthly mean climatology of tsf +! + kpd7 = -1 + do nn=1,2 + mon = mon1 + if (nn .eq. 2) mon = mon2 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo +! +! tsf at the begining of forecast i.e. fh=0 +! + do i=1,len + tsfcl0(i) = wei1m * tsf(i,1) + wei2m * tsf(i,2) + enddo + endif + endif +! +! compute current jy,jm,jd,jh of forecast and the day of the year +! + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha = 0 + ida = 0 + jda = 0 + fha(2) = nint(fh) + ida(1) = iy + ida(2) = im + ida(3) = id + ida(5) = ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy = jda(1) + jm = jda(2) + jd = jda(3) + jh = jda(5) +! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', +! & jy,jm,jd,jh,rjday + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday = jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. + + if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday +! + if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! +! for monthly mean climatology +! + monend = 12 + do mm=1,monend + mmm=mm + mmp=mm+1 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + mon1=mmm + mon2=mmp + go to 20 + endif + enddo + print *,'wrong rjday',rjday + call abort + 20 continue + wei1m=(dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) + wei2m=(rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if(mon2.eq.13) mon2=1 + if (me .eq. 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m +! +! for seasonal mean climatology +! + monend = 4 + is = im/3 + 1 + if (is.eq.5) is = 1 + do mm=1,monend + mmm = mm*3 - 2 + mmp = (mm+1)*3 - 2 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + sea1 = mmm + sea2 = mmp + go to 30 + endif + enddo + print *,'wrong rjday',rjday + call abort + 30 continue + wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1)) + wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) + if(sea2.eq.13) sea2=1 + if (me .eq. 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', + & rjday,sea1,sea2,wei1s,wei2s +! +! for summer and winter values (maximum and minimum). +! + monend = 2 + is = im/6 + 1 + if (is.eq.3) is = 1 + do mm=1,monend + mmm = mm*6 - 5 + mmp = (mm+1)*6 - 5 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + hyr1 = mmm + hyr2 = mmp + go to 31 + endif + enddo + print *,'wrong rjday',rjday + call abort + 31 continue + wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1)) + wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) + if(hyr2.eq.13) hyr2=1 + if (me .eq. 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', + & rjday,hyr1,hyr2,wei1y,wei2y +! +! start reading in climatology and interpolate to the date +! + first_time : if (first) then +!cbosu + if (me == 0) print*,'bosu first time thru' +! +! annual mean climatology +! +! fraction of vegetation field for albedo -- there are two +! fraction fields in this version: strong zenith angle dependent +! and weak zenith angle dependent +! + kpd9 = -1 +cjfe + alf=0. +cjfe + + kpd7=-1 + if (ialb == 1) then +!cbosu still need facsf and facwf. read them from the production +!cbosu file + if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask + &, alf,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnalbc2, tile_num_ch, i_index, j_index, + & kpdalf(1), alf(:,1), 1, len, me) + endif + else + call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask + &, alf,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif + do i = 1, len + if(slmask(i).eq.1.) then + alf(i,2) = 100. - alf(i,1) + endif + enddo +! +! deep soil temperature +! + if(fntg3c(1:8).ne.' ') then + if ( index(fntg3c, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, + & tg3,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fntg3c, tile_num_ch, i_index, j_index, + & kpdtg3, tg3, 1, len, me) + endif + endif +! +! vegetation type +! +! when using the new gldas soil moisture climatology, a veg type +! dataset must be selected. +! + if(fnvetc(1:8).ne.' ') then + if ( index(fnvetc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, + & vet,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + landice_cat=13 + if (maxval(vet)> 13.0) landice_cat=15 + else + call fixrdc_tile(fnvetc, tile_num_ch, i_index, j_index, + & kpdvet, vet, 1, len, me) + landice_cat=15 + endif + if (me .eq. 0) write(6,*) 'climatological vegetation', + & ' type read in.' + elseif(index(fnsmcc,'soilmgldas') /= 0) then ! new soil moisture climo + if (me .eq. 0) write(6,*) 'fatal error: must choose' + if (me .eq. 0) write(6,*) 'climatological veg type when' + if (me .eq. 0) write(6,*) 'using new gldas soil moisture.' + call abort + endif +! +! soil type +! + if(fnsotc(1:8).ne.' ') then + if ( index(fnsotc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, + & sot,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnsotc, tile_num_ch, i_index, j_index, + & kpdsot, sot, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological soil type read in.' + endif + +! +! min vegetation cover +! + if(fnvmnc(1:8).ne.' ') then + if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, + & vmn,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvmnc, tile_num_ch, i_index, j_index, + & 257, vmn, 99, len, me) + + endif + if (me .eq. 0) write(6,*) 'climatological shdmin read in.' + endif +! +! max vegetation cover +! + if(fnvmxc(1:8).ne.' ') then + if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, + & vmx,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvmxc, tile_num_ch, i_index, j_index, + & 256, vmx, 99, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological shdmax read in.' + endif +! +! slope type +! + if(fnslpc(1:8).ne.' ') then + if ( index(fnslpc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, + & slp,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnslpc, tile_num_ch, i_index, j_index, + & kpdslp, slp, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological slope read in.' + endif +! +! max snow albeod +! + if(fnabsc(1:8).ne.' ') then + if ( index(fnabsc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, + & absm,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index, + & kpdabs, absm, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological snoalb read in.' + endif +!clu ---------------------------------------------------------------------- +! + is1 = sea1/3 + 1 + is2 = sea2/3 + 1 + if (is1 .eq. 5) is1 = 1 + if (is2 .eq. 5) is2 = 1 + do nn=1,2 +! +! seasonal mean climatology + if(nn.eq.1) then + isx=is1 + else + isx=is2 + endif + if(isx.eq.1) kpd9 = 12 + if(isx.eq.2) kpd9 = 3 + if(isx.eq.3) kpd9 = 6 + if(isx.eq.4) kpd9 = 9 +! +! seasonal mean climatology +! +! albedo +! there are four albedo fields in this version: +! two for strong zeneith angle dependent (visible and near ir) +! and two for weak zeneith angle dependent (vis ans nir) +! + if (ialb == 0) then + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + endif +! +! monthly mean climatology +! + mon = mon1 + if (nn .eq. 2) mon = mon2 +!cbosu +!cbosu new snowfree albedo database is monthly. + if (ialb == 1) then + if ( index(fnalbc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + else + do k = 1, 4 + call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, + & kpdalb(k), alb(:,k,nn), mon, len, me) + enddo + endif + endif + +! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2 +! +! tsf at the current time t +! + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn +! +! tsf...at time t-deltsfc +! +! fh2 = fh - deltsfc +! if (fh2 .gt. 0.0) then +! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, +! & iy,im,id,ih,fh2,tsfcl2,len,iret +! &, imsk, jmsk, slmskh, gaus,blno, blto +! &, outlat, outlon, me) +! else +! do i=1,len +! tsfcl2(i) = tsfclm(i) +! enddo +! endif +! +! soil wetness +! + if(fnwetc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + & wet(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnsmcc(1:8).ne.' ') then + if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data + kpd7=-1 + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + & smc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + smc(i,l,nn) = smc(i,lsoil,nn) + enddo + enddo + else ! the new gldas data. it does not have data defined at landice + ! points. so for efficiency, don't have fixrdc try to + ! find a value at landice points as defined by the vet type (vet). + allocate(slmask_noice(len)) + slmask_noice=1.0 + do i = 1, len + if (nint(vet(i)) < 1 .or. + & nint(vet(i)) == landice_cat) then + slmask_noice(i) = 0.0 + endif + enddo + do k = 1, lsoil + if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) + if (k==2) kpd7=2600 ! 10_40 cm + if (k==3) kpd7=10340 ! 40_100 cm + if (k==4) kpd7=25800 ! 100_200 cm + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, + & smc(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + deallocate(slmask_noice) + endif + else + write(6,*) 'climatological soil wetness file not given' + call abort + endif +! +! soil temperature +! + if(fnstcc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, + & stc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + stc(i,l,nn) = stc(i,lsoil,nn) + enddo + enddo + endif +! +! sea ice +! + kpd7=-1 + if(fnacnc(1:8).ne.' ') then + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + & acn(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnaisc(1:8).ne.' ') then + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + & ais(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + write(6,*) 'climatological ice cover file not given' + call abort + endif +! +! snow depth +! + kpd7=-1 + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + & sno(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! snow cover +! + if(fnscvc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + & scv(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + write(6,*) 'climatological snow cover read in.' + endif +! +! surface roughness +! + if(fnzorc(1:3) == 'sib') then + if (me == 0) then + write(6,*) 'roughness length to be set from sib veg type' + endif + elseif(fnzorc(1:4) == 'igbp') then + if (me == 0) then + write(6,*) 'roughness length to be set from igbp veg type' + endif + else + kpd7=-1 + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + & zor(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +! + do i = 1, len +! set clouds climatology to zero + cvclm (i) = 0. + cvbclm(i) = 0. + cvtclm(i) = 0. +! + cnpclm(i) = 0. !set canopy water content climatology to zero + enddo +! +! vegetation cover +! + if(fnvegc(1:8).ne.' ') then + if ( index(fnvegc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + & veg(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, + & kpdveg, veg(:,nn), mon, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological vegetation', + & ' cover read in for mon=',mon + endif + + enddo +! + mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2 +! + if (me .eq. 0) print *,' mon1s=',mon1s,' mon2s=',mon2s + &,' sea1s=',sea1s,' sea2s=',sea2s +! + k1 = 1 ; k2 = 2 + m1 = 1 ; m2 = 2 +! + first = .false. + endif first_time +! +! to get tsf climatology at the previous call to sfccycle +! +! if (fh-deltsfc >= 0.0) then + rjdayh = rjday - deltsfc/24.0 +! else +! rjdayh = rjday +! endif +! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2=' +! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2 + if (rjdayh .ge. dayhf(mon1)) then + if (mon2 .eq. 1) mon2 = 13 + wei1x = (dayhf(mon2)-rjdayh)/(dayhf(mon2)-dayhf(mon1)) + wei2x = 1.0 - wei1x + if (mon2 .eq. 13) mon2 = 1 + else + rjdayh2 = rjdayh + if (rjdayh .lt. dayhf(1)) rjdayh2 = rjdayh2 + 365.0 + if (mon1s .eq. mon1) then + mon1s = mon1 - 1 + if (mon1s .eq. 0) mon1s = 12 + k2 = k1 + k1 = mod(k2,2) + 1 + mon = mon1s + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,k1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif + mon2s = mon1s + 1 +! if (mon2s .eq. 1) mon2s = 13 + wei1x = (dayhf(mon2s)-rjdayh2)/(dayhf(mon2s)-dayhf(mon1s)) + wei2x = 1.0 - wei1x + if (mon2s .eq. 13) mon2s = 1 + do i=1,len + tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) + enddo + endif +! +!cbosu new albedo is monthly + if (sea1 .ne. sea1s) then + sea1s = sea1 + sea2s = sea2 + m1 = mod(m1,2) + 1 + m2 = mod(m1,2) + 1 +! +! seasonal mean climatology +! + isx = sea2/3 + 1 + if (isx .eq. 5) isx = 1 + if(isx.eq.1) kpd9 = 12 + if(isx.eq.2) kpd9 = 3 + if(isx.eq.3) kpd9 = 6 + if(isx.eq.4) kpd9 = 9 +! +! albedo +! there are four albedo fields in this version: +! two for strong zeneith angle dependent (visible and near ir) +! and two for weak zeneith angle dependent (vis ans nir) +! +!cbosu + if (ialb == 0) then + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask + &, alb(1,k,m2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + endif + + endif + + if (mon1 .ne. mon1s) then + + mon1s = mon1 + mon2s = mon2 + k1 = mod(k1,2) + 1 + k2 = mod(k1,2) + 1 +! +! monthly mean climatology +! + mon = mon2 + nn = k2 +!cbosu + if (ialb == 1) then + if (me == 0) print*,'bosu 2nd time in clima for month ', + & mon, k1,k2 + if ( index(fnalbc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + else + do k = 1, 4 + call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, + & kpdalb(k), alb(:,k,nn), mon, len, me) + enddo + endif + endif +! +! tsf at the current time t +! + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! soil wetness +! + if(fnwetc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + & wet(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnsmcc(1:8).ne.' ') then + if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data + kpd7=-1 + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + & smc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + smc(i,l,nn) = smc(i,lsoil,nn) + enddo + enddo + else ! the new gldas data. it does not have data defined at landice + ! points. so for efficiency, don't have fixrdc try to + ! find a value at landice points as defined by the vet type (vet). + allocate(slmask_noice(len)) + slmask_noice=1.0 + do i = 1, len + if (nint(vet(i)) < 1 .or. + & nint(vet(i)) == landice_cat) then + slmask_noice(i) = 0.0 + endif + enddo + do k = 1, lsoil + if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) + if (k==2) kpd7=2600 ! 10_40 cm + if (k==3) kpd7=10340 ! 40_100 cm + if (k==4) kpd7=25800 ! 100_200 cm + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, + & smc(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + deallocate(slmask_noice) + endif + else + write(6,*) 'climatological soil wetness file not given' + call abort + endif +! +! sea ice +! + kpd7=-1 + if(fnacnc(1:8).ne.' ') then + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + & acn(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnaisc(1:8).ne.' ') then + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + & ais(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + write(6,*) 'climatological ice cover file not given' + call abort + endif +! +! snow depth +! + kpd7=-1 + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + & sno(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! snow cover +! + if(fnscvc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + & scv(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + write(6,*) 'climatological snow cover read in.' + endif +! +! surface roughness +! + if(fnzorc(1:3) == 'sib') then + if (me == 0) then + write(6,*) 'roughness length to be set from sib veg type' + endif + elseif(fnzorc(1:4) == 'igbp') then + if (me == 0) then + write(6,*) 'roughness length to be set from igbp veg type' + endif + else + kpd7=-1 + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + & zor(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +! +! vegetation cover +! + if(fnvegc(1:8).ne.' ') then + if ( index(fnvegc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + & veg(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, + & kpdveg, veg(:,nn), mon, len, me) + endif +! if (me .eq. 0) write(6,*) 'climatological vegetation', +! & ' cover read in for mon=',mon + endif +! + endif +! +! now perform the time interpolation +! +! when chosen, set the z0 based on the vegetation type. +! for this option to work, namelist variable fnvetc must be +! set to point at the proper vegetation type file. + if(fnzorc(1:3) == 'sib') then + if(fnvetc(1:4) == ' ') then + if (me==0) write(6,*) "must choose sib veg type climo file" + call abort + endif + zorclm = 0.0 + do i=1,len + ivtyp=nint(vet(i)) + if (ivtyp >= 1 .and. ivtyp <= 13) then + zorclm(i) = z0_sib(ivtyp) + endif + enddo + elseif(fnzorc(1:4) == 'igbp') then + if(fnvetc(1:4) == ' ') then + if (me==0) write(6,*) "must choose igbp veg type climo file" + call abort + endif + zorclm = 0.0 + do i=1,len + ivtyp=nint(vet(i)) + if (ivtyp >= 1 .and. ivtyp <= 20) then + z0_season(1) = z0_igbp_min(ivtyp) + z0_season(7) = z0_igbp_max(ivtyp) + if(outlat(i) < 0.0)then + zorclm(i) = wei1y * z0_season(hyr2) + + & wei2y *z0_season(hyr1) + else + zorclm(i) = wei1y * z0_season(hyr1) + + & wei2y *z0_season(hyr2) + endif + endif + enddo + else + do i=1,len + zorclm(i) = wei1m * zor(i,k1) + wei2m * zor(i,k2) + enddo + endif +! + do i=1,len + tsfclm(i) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2) + snoclm(i) = wei1m * sno(i,k1) + wei2m * sno(i,k2) + cvclm(i) = 0.0 + cvbclm(i) = 0.0 + cvtclm(i) = 0.0 + cnpclm(i) = 0.0 + tsfcl2(i) = tsf2(i) + enddo +! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m +! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) +! + if (fh .eq. 0.0) then + do i=1,len + tsfcl0(i) = tsfclm(i) + enddo + endif + if (rjdayh .ge. dayhf(mon1)) then + do i=1,len + tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) + tsfcl2(i) = tsf2(i) + enddo + endif +! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x +! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) +! &,' mon1s=',mon1s,' mon2s=',mon2s +! &,' slmask=',slmask(iprnt) +! + if(fnacnc(1:8).ne.' ') then + do i=1,len + acnclm(i) = wei1m * acn(i,k1) + wei2m * acn(i,k2) + enddo + elseif(fnaisc(1:8).ne.' ') then + do i=1,len + aisclm(i) = wei1m * ais(i,k1) + wei2m * ais(i,k2) + enddo + endif +! + if(fnwetc(1:8).ne.' ') then + do i=1,len + wetclm(i) = wei1m * wet(i,k1) + wei2m * wet(i,k2) + enddo + elseif(fnsmcc(1:8).ne.' ') then + do k=1,lsoil + do i=1,len + smcclm(i,k) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2) + enddo + enddo + endif +! + if(fnscvc(1:8).ne.' ') then + do i=1,len + scvclm(i) = wei1m * scv(i,k1) + wei2m * scv(i,k2) + enddo + endif +! + if(fntg3c(1:8).ne.' ') then + do i=1,len + tg3clm(i) = tg3(i) + enddo + elseif(fnstcc(1:8).ne.' ') then + do k=1,lsoil + do i=1,len + stcclm(i,k) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2) + enddo + enddo + endif +! + if(fnvegc(1:8).ne.' ') then + do i=1,len + vegclm(i) = wei1m * veg(i,k1) + wei2m * veg(i,k2) + enddo + endif +! + if(fnvetc(1:8).ne.' ') then + do i=1,len + vetclm(i) = vet(i) + enddo + endif +! + if(fnsotc(1:8).ne.' ') then + do i=1,len + sotclm(i) = sot(i) + enddo + endif + + +!clu ---------------------------------------------------------------------- +! + if(fnvmnc(1:8).ne.' ') then + do i=1,len + vmnclm(i) = vmn(i) + enddo + endif +! + if(fnvmxc(1:8).ne.' ') then + do i=1,len + vmxclm(i) = vmx(i) + enddo + endif +! + if(fnslpc(1:8).ne.' ') then + do i=1,len + slpclm(i) = slp(i) + enddo + endif +! + if(fnabsc(1:8).ne.' ') then + do i=1,len + absclm(i) = absm(i) + enddo + endif +!clu ---------------------------------------------------------------------- +! +!cbosu diagnostic print + if (me == 0) print*,'monthly albedo weights are ', + & wei1m,' for k', k1, wei2m, ' for k', k2 + + if (ialb == 1) then + do k=1,4 + do i=1,len + albclm(i,k) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2) + enddo + enddo + else + do k=1,4 + do i=1,len + albclm(i,k) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2) + enddo + enddo + endif +! + do k=1,2 + do i=1,len + alfclm(i,k) = alf(i,k) + enddo + enddo +! +! end of climatology reads +! + return + end subroutine clima + +!>\ingroup mod_sfcsub + subroutine fixrdc_tile(filename_raw, tile_num_ch, + & i_index, j_index, kpds, + & var, mon, npts, me) + use netcdf + use machine , only : kind_io8 + implicit none + character(len=*), intent(in) :: filename_raw + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: npts, me, kpds, mon + integer, intent(in) :: i_index(npts) + integer, intent(in) :: j_index(npts) + real(kind_io8), intent(out) :: var(npts) + character(len=500) :: filename + character(len=80) :: errmsg + integer :: i, ii, ncid, t + integer :: error, id_dim + integer :: nx, ny, num_times + integer :: id_var + real(kind=4), allocatable :: dummy(:,:,:) + ii=index(filename_raw,"tileX") + + do i = 1, len(filename) + filename(i:i) = " " + enddo + + filename = filename_raw(1:ii-1) // tile_num_ch // ".nc" + + if (me == 0) print*, ' in fixrdc_tile for mon=',mon, + & ' filename=', trim(filename) + + error=nf90_open(trim(filename), nf90_nowrite, ncid) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'nx', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=nx) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'ny', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=ny) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'time', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=num_times) + if (error /= nf90_noerr) call netcdf_err(error) + + select case (kpds) + case(11) + error=nf90_inq_varid(ncid, 'substrate_temperature', id_var) + case(87) + error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) + case(159) + error=nf90_inq_varid(ncid, 'maximum_snow_albedo', id_var) + case(189) + error=nf90_inq_varid(ncid, 'visible_black_sky_albedo', id_var) + case(190) + error=nf90_inq_varid(ncid, 'visible_white_sky_albedo', id_var) + case(191) + error=nf90_inq_varid(ncid, 'near_IR_black_sky_albedo', id_var) + case(192) + error=nf90_inq_varid(ncid, 'near_IR_white_sky_albedo', id_var) + case(214) + error=nf90_inq_varid(ncid, 'facsf', id_var) + case(224) + error=nf90_inq_varid(ncid, 'soil_type', id_var) + case(225) + error=nf90_inq_varid(ncid, 'vegetation_type', id_var) + case(236) + error=nf90_inq_varid(ncid, 'slope_type', id_var) + case(256:257) + error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) + case default + print*,'fatal error in fixrdc_tile of sfcsub.F.' + print*,'unknown variable.' + call abort + end select + if (error /= nf90_noerr) call netcdf_err(error) + + allocate(dummy(nx,ny,1)) + + if (kpds == 256) then ! max veg greenness + + var = -9999. + do t = 1, num_times + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + do ii = 1,npts + var(ii) = max(var(ii), dummy(i_index(ii),j_index(ii),1)) + enddo + enddo + + elseif (kpds == 257) then ! min veg greenness + + var = 9999. + do t = 1, num_times + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + do ii = 1, npts + var(ii) = min(var(ii), dummy(i_index(ii),j_index(ii),1)) + enddo + enddo + + else + + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,mon/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + + do ii = 1, npts + var(ii) = dummy(i_index(ii),j_index(ii),1) + enddo + + endif + + deallocate(dummy) + + error=nf90_close(ncid) + + select case (kpds) + case(159) ! max snow alb + var = var * 100.0 + case(214) ! facsf + where (var < 0.0) var = 0.0 + var = var * 100.0 + case(189:192) + var = var * 100.0 + case(256:257) + var = var * 100.0 + end select + + return + + end subroutine fixrdc_tile + +!>\ingroup mod_sfcsub + subroutine netcdf_err(error) + + use netcdf + implicit none + + integer,intent(in) :: error + character(len=256) :: errmsg + + errmsg = nf90_strerror(error) + print*,'fatal error in sfcsub.F: ', trim(errmsg) + call abort + + end subroutine netcdf_err + +!>\ingroup mod_sfcsub + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, + & gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata + implicit none + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami + &, jj,w3kindreal,w3kindint + real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto +! +! read in grib climatology files and interpolate to the input +! grid. grib files should allow all the necessary parameters +! to be extracted from the description records. +! +! + character*500 fngrib +! character*80 fngrib, asgnstr +! + real (kind=kind_io8) slmskh(imsk,jmsk) +! + real (kind=kind_io8) gdata(len), slmask(len) + real (kind=kind_io8), allocatable :: data(:,:), rslmsk(:,:) + real (kind=kind_io8), allocatable :: data8(:) + real (kind=kind_io4), allocatable :: data4(:) + real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) +! + logical lmask, yr2kc, gaus, ijordr + logical*1, allocatable :: lbms(:) +! + integer, intent(in) :: kpds7 + integer kpds(1000),kgds(1000) + integer jpds(1000),jgds(1000), kpds0(1000) + real (kind=kind_io8) outlat(len), outlon(len) +! + allocate(data8(1:mdata)) + allocate(lbms(mdata)) +! +! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv +! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/ +! &, kpds1_sv/-1/ +! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv +! &, rlngrb, rltgrb +! + iret = 0 +! + if (me .eq. 0) write(6,*) ' in fixrdc for mon=',mon + &,' fngrib=',trim(fngrib) +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0) write(6,*) ' file ',trim(fngrib), + & ' opened. unit=',lugb +! + lugi = 0 +! + lskip = -1 + jpds = -1 + jgds = -1 + jpds(5) = kpds5 + jpds(7) = kpds7 + kpds = jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + if (me .eq. 0) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif + yr2kc = (kpds(8) / 100) .gt. 0 + kpds0 = jpds + kpds0(4) = -1 + kpds0(18) = -1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if (iret==99) write(6,*) ' field not found.' + call abort + endif +! +! handling climatology file +! + lskip = -1 + n = 0 + jpds = kpds0 + jpds(9) = mon + if(jpds(9).eq.13) jpds(9) = 1 + call w3kind(w3kindreal,w3kindint) + if (w3kindreal==8) then + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + else if (w3kindreal==4) then + allocate(data4(1:mdata)) + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = real(data4, kind=kind_io8) + deallocate(data4) + endif + if (me .eq. 0) write(6,*) ' input grib file dates=', + & (kpds(i),i=8,11) + if(jret.eq.0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + imax=kgds(2) + jmax=kgds(3) + ijmax=imax*jmax + allocate (data(imax,jmax)) + do j=1,jmax + jj = (j-1)*imax + do i=1,imax + data(i,j) = data8(jj+i) + enddo + enddo + if (me .eq. 0) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax + else + write(6,*) ' error in getgb - jret=', jret + call abort + endif +! +! if (me == 0) then +! write(6,*) ' maxmin of input as is' +! kmami=1 +! call maxmin(data(1,1),ijmax,kmami) +! endif +! + call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) + if (me == 0) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + endif + call subst(data,imax,jmax,dlon,dlat,ijordr) +! +! first get slmask over input grid +! + allocate (rlngrb(imax), rltgrb(jmax)) + allocate (rslmsk(imax,jmax)) + + call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, + & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk + &, gaus,blno, blto, kgds(1), kpds(4), lbms) +! write(6,*) ' kpds5=',kpds5,' lmask=',lmask +! + inttyp = 0 + if(kpds5.eq.225) inttyp = 1 + if(kpds5.eq.230) inttyp = 1 + if(kpds5.eq.236) inttyp = 1 + if(kpds5.eq.224) inttyp = 1 + if (me .eq. 0) then + if(inttyp.eq.1) print *, ' nearest grid point used' + &, ' kpds5=',kpds5, ' lmask = ',lmask + endif +! + call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, + & gdata,len,lmask,rslmsk,slmask + &, outlat, outlon,me) +! + deallocate (rlngrb, stat=iret) + deallocate (rltgrb, stat=iret) + deallocate (data, stat=iret) + deallocate (rslmsk, stat=iret) + call baclose(lugb,iret) +! + deallocate(data8) + deallocate(lbms) + return + end subroutine fixrdc + +!>\ingroup mod_sfcsub + subroutine fixrda(lugb,fngrib,kpds5,slmask, + & iy,im,id,ih,fh,gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata + implicit none + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, + & rjday,blto +! +! read in grib climatology/analysis files and interpolate to the input +! dates and the grid. grib files should allow all the necessary parameters +! to be extracted from the description records. +! +! nrepmx: max number of days for going back date search +! nvalid: analysis later than (current date - nvalid) is regarded as +! valid for current analysis +! + parameter(nrepmx=15, nvalid=4) +! + character*500 fngrib +! character*80 fngrib, asgnstr +! + real (kind=kind_io8) slmskh(imsk,jmsk) +! + real (kind=kind_io8) gdata(len), slmask(len) + real (kind=kind_io8), allocatable :: data(:,:),rslmsk(:,:) + real (kind=kind_io8), allocatable :: data8(:) + real (kind=kind_io4), allocatable :: data4(:) + real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) +! + logical lmask, yr2kc, gaus, ijordr + logical*1 lbms(mdata) +! + integer kpds(1000),kgds(1000) + integer jpds(1000),jgds(1000), kpds0(1000) + real (kind=kind_io8) outlat(len), outlon(len) +! +! dayhf : julian day of the middle of each month +! + real (kind=kind_io8) dayhf(13) + data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, + & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ +! +! mjday : number of days in a month +! + integer mjday(12) + data mjday/31,28,31,30,31,30,31,31,30,31,30,31/ +! + real (kind=kind_io8) fha(5) + real(4) fha4(5) + integer ida(8),jda(8) +! + allocate(data8(1:mdata)) + iret = 0 + monend = 9999 +! +! compute jy,jm,jd,jh of forecast and the day of the year +! + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha=0 + ida=0 + jda=0 + fha(2)=nint(fh) + ida(1)=iy + ida(2)=im + ida(3)=id + ida(5)=ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy=jda(1) + jm=jda(2) + jd=jda(3) + jh=jda(5) +! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', +! & jy,jm,jd,jh,rjday + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday=jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. + + if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday +! + if (me .eq. 0) then + write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! + write(6,*) ' ' + write(6,*) '************************************************' + endif +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0) write(6,*) ' file ',trim(fngrib), + & ' opened. unit=',lugb +! + lugi = 0 +! + lskip=-1 + jpds=-1 + jgds=-1 + jpds(5)=kpds5 + kpds = jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + if (me .eq. 0) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif + yr2kc = (kpds(8) / 100) .gt. 0 + kpds0=jpds + kpds0(4)=-1 + kpds0(18)=-1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if(iret==99) write(6,*) ' field not found.' + call abort + endif +! +! handling analysis file +! +! find record for the given hour/day/month/year +! + nrept=0 + jpds=kpds0 + lskip = -1 + iyr=jy + if(iyr.le.100) iyr=2050-mod(2050-iyr,100) + imo=jm + idy=jd + ihr=jh +! year 2000 compatible data + if (yr2kc) then + jpds(8) = iyr + else + jpds(8) = mod(iyr,1900) + endif + 50 continue + jpds( 8)=mod(iyr-1,100)+1 + jpds( 9)=imo + jpds(10)=idy +! jpds(11)=ihr + jpds(21)=(iyr-1)/100+1 + call w3kind(w3kindreal,w3kindint) + if (w3kindreal == 8) then + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + elseif (w3kindreal == 4) then + allocate (data4(1:mdata)) + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = real(data4, kind=kind_io8) + deallocate(data4) + endif + if (me .eq. 0) write(6,*) ' input grib file dates=', + & (kpds(i),i=8,11) + if(jret.eq.0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + imax=kgds(2) + jmax=kgds(3) + ijmax=imax*jmax + allocate (data(imax,jmax)) + do j=1,jmax + jj = (j-1)*imax + do i=1,imax + data(i,j) = data8(jj+i) + enddo + enddo + else + if(nrept.eq.0) then + if (me .eq. 0) then + write(6,*) ' no matching dates found. start searching', + & ' nearest matching dates (going back).' + endif + endif +! +! no matching ih found. search nearest hour +! + if(ihr.eq.6) then + ihr=0 + go to 50 + elseif(ihr.eq.12) then + ihr=0 + go to 50 + elseif(ihr.eq.18) then + ihr=12 + go to 50 + elseif(ihr.eq.0.or.ihr.eq.-1) then + idy=idy-1 + if(idy.eq.0) then + imo=imo-1 + if(imo.eq.0) then + iyr=iyr-1 + if(iyr.lt.0) iyr=99 + imo=12 + endif + idy=31 + if(imo.eq.4.or.imo.eq.6.or.imo.eq.9.or.imo.eq.11) idy=30 + if(imo.eq.2) then + if(mod(iyr,4).eq.0) then + idy=29 + else + idy=28 + endif + endif + endif + ihr=-1 + if (me .eq. 0) write(6,*) ' decremented dates=', + & iyr,imo,idy,ihr + nrept=nrept+1 + if(nrept.gt.nvalid) iret=-1 + if(nrept.gt.nrepmx) then + if (me .eq. 0) then + write(6,*) ' searching range exceeded.' + &, ' may be wrong grib file given' + write(6,*) ' fngrib=',trim(fngrib) + write(6,*) ' terminating search and', + & ' and setting gdata to -999' + write(6,*) ' range max=',nrepmx + endif +! imax=kgds(2) +! jmax=kgds(3) +! ijmax=imax*jmax +! do ij=1,ijmax +! data(ij)=0. +! enddo + go to 100 + endif + go to 50 + else + if (me .eq. 0) then + write(6,*) ' search of analysis for ihr=',ihr,' failed.' + write(6,*) ' kpds=',kpds + write(6,*) ' iyr,imo,idy,ihr=',iyr,imo,idy,ihr + endif + go to 100 + endif + endif +! + 80 continue +! if (me == 0) then +! write(6,*) ' maxmin of input as is' +! kmami=1 +! call maxmin(data(1,1),ijmax,kmami) +! endif +! + call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) + if (me == 0) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + endif + call subst(data,imax,jmax,dlon,dlat,ijordr) +! +! first get slmask over input grid +! + allocate (rlngrb(imax), rltgrb(jmax)) + allocate (rslmsk(imax,jmax)) + call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, + & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk +! & data,imax,jmax,abs(dlon),abs(dlat),lmask,rslmsk +!cggg &, gaus,blno, blto, kgds(1)) + &, gaus,blno, blto, kgds(1), kpds(4), lbms) + +! write(6,*) ' kpds5=',kpds5,' lmask=',lmask +! + inttyp = 0 + if(kpds5.eq.225) inttyp = 1 + if(kpds5.eq.230) inttyp = 1 + if(kpds5.eq.66) inttyp = 1 + if(inttyp.eq.1) print *, ' nearest grid point used' +! + call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, + & gdata,len,lmask,rslmsk,slmask + &, outlat, outlon, me) +! + deallocate (rlngrb, stat=iret) + deallocate (rltgrb, stat=iret) + deallocate (data, stat=iret) + deallocate (rslmsk, stat=iret) + call baclose(lugb,iret2) +! write(6,*) ' ' + deallocate(data8) + return +! + 100 continue + iret=1 + do i=1,len + gdata(i) = -999. + enddo +! + call baclose(lugb,iret2) +! + deallocate(data8) + return + end subroutine fixrda + +!>\ingroup mod_sfcsub + subroutine snodpth2(glacir,snwmax,snoanl, len, me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,me,len + real (kind=kind_io8) snwmax +! + real (kind=kind_io8) snoanl(len), glacir(len) +! + if (me .eq. 0) write(6,*) 'snodpth2' +! + do i=1,len +! +! if glacial points has snow in climatology, set sno to snomax +! + if(glacir(i).ne.0..and.snoanl(i).lt.snwmax*0.5) then + snoanl(i) = snwmax + snoanl(i) + endif +! + enddo + return + end +!>@} From ca43794963a6a80fa4dcee2f43e0aee87273e251 Mon Sep 17 00:00:00 2001 From: Man Zhang Date: Thu, 20 Jun 2019 16:26:31 -0600 Subject: [PATCH 14/19] scidoc fv3 updates --- physics/GFS_phys_time_vary.fv3.F90 | 34 +- physics/GFS_rad_time_vary.fv3.F90 | 7 +- physics/docs/ccppv3_fv3_doxyfile | 4 +- physics/docs/pdftxt/GFS_SAMF.txt | 1 + physics/sfcsub.F | 835 ++++++++++++++--------------- 5 files changed, 438 insertions(+), 443 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index b8823fac6..80a55529c 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -2,8 +2,9 @@ !! Contains code related to GFS physics suite setup (physics part of time_vary_step) !>\defgroup mod_GFS_phys_time_vary GFS Physics Time Update -!! This module contains GFS physics time vary subroutines including ozone, h2o, i -!! aerosol and IN&CCN updates. +!! This module contains GFS physics time vary subroutines including ozone, stratospheric water vapor, +!! aerosol, IN&CCN and surface properties updates. +!> @{ module GFS_phys_time_vary #ifdef OPENMP @@ -42,6 +43,8 @@ module GFS_phys_time_vary !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! +!>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm +!! @{ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, errflg) use GFS_typedefs, only: GFS_control_type, GFS_data_type, GFS_interstitial_type @@ -111,6 +114,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e !$OMP sections !$OMP section +!> - Call read_o3data() to read ozone data call read_o3data (Model%ntoz, Model%me, Model%master) ! Consistency check that the hardcoded values for levozp and @@ -130,6 +134,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e end if !$OMP section +!> - Call read_h2odata() to read stratospheric water vapor data call read_h2odata (Model%h2o_phys, Model%me, Model%master) ! Consistency check that the hardcoded values for levh2o and @@ -149,6 +154,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e end if !$OMP section +!> - Call read_aerdata() to read aerosol climatology if (Model%aero_in) then ! Consistency check that the value for ntrcaerm set in GFS_typedefs.F90 ! and used to allocate Tbd%aer_nm matches the value defined in aerclm_def @@ -173,6 +179,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e endif !$OMP section +!> - Call read_cidata() to read IN and CCN data if (Model%iccn) then call read_cidata ( Model%me, Model%master) ! No consistency check needed for in/ccn data, all values are @@ -204,7 +211,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e end if - !--- read in and initialize ozone +!> - Call setindxoz() to initialize ozone data if (Model%ntoz > 0) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -214,7 +221,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e !$OMP end do endif - !--- read in and initialize stratospheric water +!> - Call setindxh2o() to initialize stratospheric water vapor data if (Model%h2o_phys) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -224,7 +231,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e !$OMP end do endif - !--- read in and initialize aerosols +!> - Call setindxaer() to initialize aerosols data if (Model%aero_in) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -236,7 +243,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e !$OMP end do endif - !--- read in and initialize IN and CCN +!> - Call setindxci() to initialize IN and CCN data if (Model%iccn) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -267,6 +274,7 @@ subroutine GFS_phys_time_vary_init (Data, Model, Interstitial, nthrds, errmsg, e is_initialized = .true. end subroutine GFS_phys_time_vary_init +!! @} !> \section arg_table_GFS_phys_time_vary_finalize Argument Table @@ -324,6 +332,8 @@ end subroutine GFS_phys_time_vary_finalize !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! +!>\section gen_GFS_phys_time_vary_run GFS_phys_time_vary_run General Algorithm +!> @{ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) use mersenne_twister, only: random_setseed, random_number @@ -412,7 +422,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) enddo endif ! imfdeepcnv, cal_re, random_clds - !--- o3 interpolation +!> - Call ozinterpol() to make ozone interpolation if (Model%ntoz > 0) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -423,7 +433,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) !$OMP end do endif - !--- h2o interpolation +!> - Call h2ointerpol() to make stratospheric water vapor data interpolation if (Model%h2o_phys) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -434,7 +444,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) !$OMP end do endif - !--- aerosol interpolation +!> - Call aerinterpol() to make aerosol interpolation if (Model%aero_in) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -449,7 +459,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) !$OMP end do endif - !--- ICCN interpolation +!> - Call ciinterpol() to make IN and CCN data interpolation if (Model%iccn) then !$OMP do schedule (dynamic,1) do nb = 1, nblks @@ -465,7 +475,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) !$OMP end parallel - !--- repopulate specific time-varying sfc properties for AMIP/forecast runs +!> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (Model%nscyc > 0) then if (mod(Model%kdt,Model%nscyc) == 1) THEN call gcycle (nblks, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) @@ -482,5 +492,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) endif end subroutine GFS_phys_time_vary_run +!> @} end module GFS_phys_time_vary +!> @} diff --git a/physics/GFS_rad_time_vary.fv3.F90 b/physics/GFS_rad_time_vary.fv3.F90 index ac96e78d0..22be34b51 100644 --- a/physics/GFS_rad_time_vary.fv3.F90 +++ b/physics/GFS_rad_time_vary.fv3.F90 @@ -10,14 +10,13 @@ module GFS_rad_time_vary contains -!>\defgroup GFS_rad_time_vary GFS RRTMG Update -!!\ingroup RRTMG -!! @{ !! \section arg_table_GFS_rad_time_vary_init Argument Table !! subroutine GFS_rad_time_vary_init end subroutine GFS_rad_time_vary_init +!>\defgroup mod_GFS_rad_time_vary GFS Radiation Time Update +!> @{ !> \section arg_table_GFS_rad_time_vary_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |-------------------|--------------------------------------------------------|-------------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| @@ -105,10 +104,10 @@ subroutine GFS_rad_time_vary_run (Model, Data, nthrds, errmsg, errflg) endif end subroutine GFS_rad_time_vary_run +!> @} !> \section arg_table_GFS_rad_time_vary_finalize Argument Table !! subroutine GFS_rad_time_vary_finalize() end subroutine GFS_rad_time_vary_finalize -!! @} end module GFS_rad_time_vary diff --git a/physics/docs/ccppv3_fv3_doxyfile b/physics/docs/ccppv3_fv3_doxyfile index f92aa9b18..b2b896b9e 100644 --- a/physics/docs/ccppv3_fv3_doxyfile +++ b/physics/docs/ccppv3_fv3_doxyfile @@ -116,7 +116,7 @@ INPUT = pdftxt/mainpage.txt \ pdftxt/GFS_OZPHYS.txt \ pdftxt/GFS_H2OPHYS.txt \ pdftxt/GFS_RAYLEIGH.txt \ - pgftxt/GFS_SAMF.txt \ + pdftxt/GFS_SAMF.txt \ pdftxt/GFS_SAMFdeep.txt \ pdftxt/GFS_GWDC.txt \ pdftxt/GFS_SAMFshal.txt \ @@ -137,6 +137,7 @@ INPUT = pdftxt/mainpage.txt \ ../gfdl_fv_sat_adj.F90 \ ### time_vary ../GFS_phys_time_vary.fv3.F90 \ + ../GFS_rad_time_vary.fv3.F90 \ ../ozne_def.f \ ../ozinterp.f90 \ ../h2o_def.f \ @@ -147,7 +148,6 @@ INPUT = pdftxt/mainpage.txt \ ../iccninterp.F90 \ ../sfcsub.F \ ../gcycle.F90 \ - ### Radiation ../radlw_main.f \ ../radsw_main.f \ diff --git a/physics/docs/pdftxt/GFS_SAMF.txt b/physics/docs/pdftxt/GFS_SAMF.txt index 870599652..192f1f9a1 100644 --- a/physics/docs/pdftxt/GFS_SAMF.txt +++ b/physics/docs/pdftxt/GFS_SAMF.txt @@ -1,5 +1,6 @@ /** \page GFS_SAMF GFS Scale-Aware Simplified Arakawa-Schubert (sa-SAS) Convection Scheme + \section des_samf Description \section intra_samf Intraphysics Communication diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 7c78707f5..391256ce0 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -2,10 +2,9 @@ !! This file contains gribcode for each parameter. -!>\defgroup mod_sfcsub_mod GFS sfcsub Module +!>\defgroup mod_sfcsub GFS sfcsub Module !!\ingroup Noah_LSM !> @{ -!>\ingroup mod_sfcsub !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). module sfccyc_module @@ -39,18 +38,37 @@ module sfccyc_module ! end module sfccyc_module -!>\ingroup mod_sfcsub - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc - &, iy,im,id,ih,fh - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl - &, sihfcs,sicfcs,sitfcs - &, swdfcs,slcfcs - &, vmnfcs,vmxfcs,slpfcs,absfcs - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs - &, vegfcs,vetfcs,sotfcs,alffcs - &, cvfcs,cvbfcs,cvtfcs,me,nlunit - &, sz_nml,input_nml_file +!>\ingroup mod_GFS_phys_time_vary +!! This subroutine reads or interpolates surface climatology data in analysis +!! and forecast mode. +!!\param lugb the unit number used in this subprogram +!!\param len number of points on which sfccyc operates +!!\param lsoil number of soil layers +!!\param sig1t sigma level 1 temperature for dead start. it should be on gaussian +!! grid. If not dead start, no need for dimension but set to zero as +!! in the example below. +!!\param deltsfc = fhcyc, frequcy for surface data cycling in hours +!!\param iy,im,id,ih year, month, day, and hour of initial state +!!\param fh forecast hour +!!\param rla, rlo latitude and longitudes of the len points +!!\param slmsk +!!\param orog +!!\param orog_uf +!!\param use_ufo +!!\param nst_anl +!! + + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh & + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & + &, sihfcs,sicfcs,sitfcs & + &, swdfcs,slcfcs & + &, vmnfcs,vmxfcs,slpfcs,absfcs & + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & + &, vegfcs,vetfcs,sotfcs,alffcs & + &, cvfcs,cvbfcs,cvtfcs,me,nlunit & + &, sz_nml,input_nml_file & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 @@ -59,90 +77,90 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc character(len=*), intent(in) :: tile_num_ch integer,intent(in) :: i_index(len), j_index(len) logical use_ufo, nst_anl - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, - & orolmx,orolmn,oroomx,oroomn,orosmx, - & orosmn,oroimx,oroimn,orojmx,orojmn, - & alblmx,alblmn,albomx,albomn,albsmx, - & albsmn,albimx,albimn,albjmx,albjmn, - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, - & snolmx,snolmn,snoomx,snoomn,snosmx, - & snosmn,snoimx,snoimn,snojmx,snojmn, - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, - & plrlmx,plrlmn,plromx,plromn,plrsmx, - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, - & stclmx,stclmn,stcomx,stcomn,stcsmx, - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, - & smclmx,smclmn,smcomx,smcomn,smcsmx, - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, - & veglmx,veglmn,vegomx,vegomn,vegsmx, - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, - & alslmx,alslmn,alsomx,alsomn,alssmx, - & alssmn,alsimx,alsimn,alsjmx,alsjmn, - & epstsf,epsalb,epssno,epswet,epszor, - & epsplr,epsoro,epssmc,epsscv,eptsfc, - & epstg3,epsais,epsacn,epsveg,epsvet, - & epssot,epsalf,qctsfs,qcsnos,qctsfi, - & aislim,snwmin,snwmax,cplrl,cplrs, - & cvegl,czors,csnol,csnos,czorl,csots, - & csotl,cvwgs,cvetl,cvets,calfs, - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, - & calbl,calfl,calbs,ctsfs,grboro, - & grbmsk,ctsfl,deltf,caisl,caiss, - & fsalfl,fsalfs,flalfs,falbl,ftsfl, - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, - & deltsfc,critp2,critp3,blnmsk,critp1, - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 - &, fsihl,fsihs,fsicl,fsics, - & csihl,csihs,csicl,csics,epssih,epssic - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, - & epsslp,epsabs - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, - & siclmx,siclmn,sicomx,sicomn,sicsmx, - & sicsmn,sicimx,sicimn,sicjmx,sicjmn - &, glacir_hice - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, - & slplmx,slplmn,slpomx,slpomn,slpsmx, - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, - & abslmx,abslmn,absomx,absomn,abssmx, - & abssmn,absimx,absimn,absjmx,absjmn + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & + & orolmx,orolmn,oroomx,oroomn,orosmx, & + & orosmn,oroimx,oroimn,orojmx,orojmn, & + & alblmx,alblmn,albomx,albomn,albsmx, & + & albsmn,albimx,albimn,albjmx,albjmn, & + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, & + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, & + & snolmx,snolmn,snoomx,snoomn,snosmx, & + & snosmn,snoimx,snoimn,snojmx,snojmn, & + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & + & zorsmn,zorimx,zorimn,zorjmx, zorjmn, & + & plrlmx,plrlmn,plromx,plromn,plrsmx, & + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, & + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, & + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, & + & stclmx,stclmn,stcomx,stcomn,stcsmx, & + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, & + & smclmx,smclmn,smcomx,smcomn,smcsmx, & + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, & + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, & + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, & + & veglmx,veglmn,vegomx,vegomn,vegsmx, & + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, & + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, & + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, & + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, & + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, & + & alslmx,alslmn,alsomx,alsomn,alssmx, & + & alssmn,alsimx,alsimn,alsjmx,alsjmn, & + & epstsf,epsalb,epssno,epswet,epszor, & + & epsplr,epsoro,epssmc,epsscv,eptsfc, & + & epstg3,epsais,epsacn,epsveg,epsvet, & + & epssot,epsalf,qctsfs,qcsnos,qctsfi, & + & aislim,snwmin,snwmax,cplrl,cplrs, & + & cvegl,czors,csnol,csnos,czorl,csots, & + & csotl,cvwgs,cvetl,cvets,calfs, & + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, & + & calbl,calfl,calbs,ctsfs,grboro, & + & grbmsk,ctsfl,deltf,caisl,caiss, & + & fsalfl,fsalfs,flalfs,falbl,ftsfl, & + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, & + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, & + & deltsfc,critp2,critp3,blnmsk,critp1, & + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, & + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, & + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, & + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 & + &, fsihl,fsihs,fsicl,fsics, & + & csihl,csihs,csicl,csics,epssih,epssic & + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, & + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, & + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, & + & epsslp,epsabs & + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, & + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, & + & siclmx,siclmn,sicomx,sicomn,sicsmx, & + & sicsmn,sicimx,sicimn,sicjmx,sicjmn & + &, glacir_hice & + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, & + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, & + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, & + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, & + & slplmx,slplmn,slpomx,slpomn,slpsmx, & + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, & + & abslmx,abslmn,absomx,absomn,abssmx, & + & abssmn,absimx,absimn,absjmx,absjmn & &, sihnew - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, - & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, - & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, - & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & + & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, & + & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, & + & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, & + & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb & &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, + logical gausm, deads, qcmsk, znlst, monclm, monanl, & & monfcs, monmer, mondif, landice character(len=*), intent(in) :: input_nml_file(sz_nml) integer num_parthds ! -!> this is a limited point version of surface program. +!> This is a limited point version of surface program. !! !! this program runs in two different modes: !! @@ -159,9 +177,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc !! forecast hour. if surface analysis file is given, for the corresponding !! dates, the program will use it. !! -!! note: -!! -!! if the date of the analysis does not match given iy,im,id,ih, (and fh), +!!\note if the date of the analysis does not match given iy,im,id,ih, (and fh), !! the program searches an old analysis by going back 6 hours, then 12 hours, !! then one day upto nrepmx days (parameter statement in the subrotine fixrd. !! now defined as 8). this allows the user to provide non-daily analysis to @@ -178,15 +194,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc !! !! for a dead start, do not supply fnbgsi or set fnbgsi=' ' ! -! lugb is the unit number used in this subprogram -! len ... number of points on which sfccyc operates -! lsoil .. number of soil layers (2 as of april, 1994) -! iy,im,id,ih .. year, month, day, and hour of initial state. -! fh .. forecast hour -! rla, rlo -- latitude and longitudes of the len points -! sig1t .. sigma level 1 temperature for dead start. should be on gaussian -! grid. if not dead start, no need for dimension but set to zero -! as in the example below. ! ! variable naming conventions: ! @@ -427,7 +434,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & &, orogd(len) real (kind=kind_io8) rla(len), rlo(len) ! @@ -440,50 +447,50 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! climatology surface fields (last character 'c' or 'clm' indicate climatology) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, - & fnvegc,fnvetc,fnsotc + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, & + & fnvegc,fnvetc,fnsotc & &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), - & zorclm(len), albclm(len,4), aisclm(len), - & tg3clm(len), acnclm(len), cnpclm(len), - & cvclm (len), cvbclm(len), cvtclm(len), - & scvclm(len), tsfcl2(len), vegclm(len), - & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), - & smcclm(len,lsoil), stcclm(len,lsoil) - &, sihclm(len), sicclm(len) + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), & + & zorclm(len), albclm(len,4), aisclm(len), & + & tg3clm(len), acnclm(len), cnpclm(len), & + & cvclm (len), cvbclm(len), cvtclm(len), & + & scvclm(len), tsfcl2(len), vegclm(len), & + & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), & + & smcclm(len,lsoil), stcclm(len,lsoil) & + &, sihclm(len), sicclm(len) & &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) ! ! analyzed surface fields (last character 'a' or 'anl' indicate analysis) ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, - & fnvega,fnveta,fnsota + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, & + & fnvega,fnveta,fnsota & &, fnvmna,fnvmxa,fnslpa,fnabsa ! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), cnpanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & scvanl(len), tsfan2(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), - & smcanl(len,lsoil), stcanl(len,lsoil) - &, sihanl(len), sicanl(len) + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & tg3anl(len), acnanl(len), cnpanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & scvanl(len), tsfan2(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), & + & smcanl(len,lsoil), stcanl(len,lsoil) & + &, sihanl(len), sicanl(len) & &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) ! real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. ! ! predicted surface fields (last characters 'fcs' indicates forecast) ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & tg3fcs(len), acnfcs(len), cnpfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2), - & smcfcs(len,lsoil), stcfcs(len,lsoil) - &, sihfcs(len), sicfcs(len), sitfcs(len) - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & + & zorfcs(len), albfcs(len,4), aisfcs(len), & + & tg3fcs(len), acnfcs(len), cnpfcs(len), & + & cvfcs (len), cvbfcs(len), cvtfcs(len), & + & slifcs(len), vegfcs(len), & + & vetfcs(len), sotfcs(len), alffcs(len,2), & + & smcfcs(len,lsoil), stcfcs(len,lsoil) & + &, sihfcs(len), sicfcs(len), sitfcs(len) & + &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) & &, swdfcs(len), slcfcs(len,lsoil) ! ! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched @@ -989,7 +996,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) !clu ---------------------------------------------------------------------- ! -! read a high resolution mask field for use in grib interpolation +!> - Call hmskrd() to read a high resolution mask field for use in grib interpolation ! call hmskrd(lugb,imsk,jmsk,fnmskh, & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) @@ -2671,7 +2678,8 @@ subroutine dayoyr(iyr,imo,idy,ldy) end !>\ingroup mod_sfcsub - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, +!! reads a high resolution mask field for use in grib interpolation + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & & kpds5,slmskh,gausm,blnmsk,bltmsk,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata, xdata, ydata @@ -2706,7 +2714,7 @@ subroutine hmskrd(lugb,imsk,jmsk,fnmskh, end !>\ingroup mod_sfcsub - subroutine fixrdg(lugb,idim,jdim,fngrib, + subroutine fixrdg(lugb,idim,jdim,fngrib, & & kpds5,gdata,gaus,blno,blto,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata @@ -2824,7 +2832,7 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, !>\ingroup mod_sfcsub !! This subroutine get area of the grib record. - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr & &, me) use machine , only : kind_io8,kind_io4 implicit none @@ -3040,24 +3048,22 @@ subroutine subst(data,imax,jmax,dlon,dlat,ijordr) !>\ingroup mod_sfcsub !! This subroutine conducts interpolation from lat/lon to Gaussian !! grid to other lat/lon grid. - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, - & gauout,len,lmask,rslmsk,slmask + subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& + & gauout,len,lmask,rslmsk,slmask & &, outlat, outlon,me) use machine , only : kind_io8,kind_io4 implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, - & wi1j2,wi2j1,rlat,rlon,aphi, + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, & + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, & + & wi1j2,wi2j1,rlat,rlon,aphi, & & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, & & ii,i1,i2,kmami,it integer nx,kxs,kxt integer, allocatable, save :: imxnx(:) integer, allocatable :: ifill(:) ! -! interpolation from lat/lon or gaussian grid to other lat/lon grid -! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), & & slmask(len) real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) ! @@ -3613,54 +3619,46 @@ subroutine maxmin(f,imax,kmax) end !>\ingroup mod_sfcsub - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, - & aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, - & aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, -!cwu [+1l] add ()clm for sih, sic - & sihclm,sicclm, -!clu [+1l] add ()clm for vmn, vmx, slp, abs - & vmnclm,vmxclm,slpclm,absclm, + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & + & aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & + & vetanl,sotanl,alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & + & aisclm, & + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & + & vetclm,sotclm,alfclm, & + & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic + & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs & len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil ! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), - & snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),scvanl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), - & snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) -!cwu [+1l] add ()clm for sih, sic - &, sihclm(len),sicclm(len) -!clu [+1l] add ()clm for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), & + & snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),scvanl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & + & snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & + &, sihclm(len),sicclm(len) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) ! do i=1,len @@ -3712,43 +3710,34 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, end !>\ingroup mod_sfcsub - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, -!clu [+1l] add fn()a for vmn, vmx, slp, abs - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, -!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, -!cggg snow mods end - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kprvet,kpdsot,kpdalf, -!clu [+1l] add kpd() for vmn, vmx, slp, abs - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf -!clu [+1l] add irt() for vmn, vmx, slp, abs - &, irtvmn,irtvmx,irtslp,irtabs - &, imsk, jmsk, slmskh, outlat, outlon + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & + & fnveta,fnsota, & + & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & + & vetanl,sotanl,alfanl,tsfan0, & + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & + & kprvet,kpdsot,kpdalf, & + & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & + & irtvet,irtsot,irtalf & + &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs + &, imsk, jmsk, slmskh, outlat, outlon & &, gaus, blno, blto, me, lanom) use machine , only : kind_io8,kind_io4 implicit none logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, -!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, -!cggg snow mods end - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j -!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! @@ -3761,21 +3750,19 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, integer lugi, lskip, lgrib, ndata !cggg snow mods end ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & & fnveta,fnsota -!clu [+1l] add fn()a for vmn, vmx, slp, abs &, fnvmna,fnvmxa,fnslpa,fnabsa - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & tg3anl(len), acnanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & slianl(len), scvanl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), - & smcanl(len,lsoil), stcanl(len,lsoil), - & tsfan0(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & tg3anl(len), acnanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & slianl(len), scvanl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2), & + & smcanl(len,lsoil), stcanl(len,lsoil), & + & tsfan0(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! logical gaus @@ -4378,53 +4365,45 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, end !>\ingroup mod_sfcsub - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs, vetfcs, sotfcs, alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl, vetanl, sotanl, alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, & + & vegfcs, vetfcs, sotfcs, alffcs, & + & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic + & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,aisanl, & + & veganl, vetanl, sotanl, alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & len,lsoil) ! use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), - & zorfcs(len),albfcs(len,4),aisfcs(len), - & tg3fcs(len), - & cvfcs (len),cvbfcs(len),cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len),vegfcs(len), - & vetfcs(len),sotfcs(len),alffcs(len,2) -!cwu [+1l] add ()fcs for sih, sic - &, sihfcs(len),sicfcs(len) -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), & + & zorfcs(len),albfcs(len,4),aisfcs(len), & + & tg3fcs(len), & + & cvfcs (len),cvbfcs(len),cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len),vegfcs(len), & + & vetfcs(len),sotfcs(len),alffcs(len,2) & + &, sihfcs(len),sicfcs(len) & + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - write(6,*) ' this is a dead start run, tsfc over land is', + write(6,*) ' this is a dead start run, tsfc over land is', & & ' set as lowest sigma level temperture if given.' write(6,*) ' if not, set to climatological tsf over land is used' ! @@ -4477,7 +4456,7 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), & & slianl(len) ! ! note that smfcs comes in with the original unit (cm?) (not grib file) @@ -4565,7 +4544,10 @@ subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) enddo return end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, + +!>\ingroup mod_sfcsub +!! This subroutine uses surface temperature to get snow depth estimate. + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & & glacir,snwmax,snwmin,landice,len,snoanl, me) use machine , only : kind_io8,kind_io4 implicit none @@ -4573,7 +4555,7 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, logical, intent(in) :: landice real (kind=kind_io8) sno,snwmax,snwmin ! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), & & snoclm(len), snoanl(len), glacir(len) ! if (me .eq. 0) write(6,*) 'snodpth' @@ -4621,80 +4603,81 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, end subroutine snodpth !>\ingroup mod_sfcsub - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, +!! This subroutine merges analysis and forecast. + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & + & sihfcs,sicfcs, & + & vmnfcs,vmxfcs,slpfcs,absfcs, & + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & + & cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & + & vetfcs,sotfcs,alffcs, & + & sihanl,sicanl, & + & vmnanl,vmxanl,slpanl,absanl, & + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,& + & cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,veganl, & + & vetanl,sotanl,alfanl, & + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, & + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, & + & calfl,calfs, & + & csihl,csihs,csicl,csics, & + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & + & irtvmn,irtvmx,irtslp,irtabs, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, - & irtalb,irtsno,irttsf,irtwet,j + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & + & irtalb,irtsno,irttsf,irtwet,j & &, irtvmn,irtvmx,irtslp,irtabs logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, - & cvets,calfs,deltsfc, - & csihl,csihs,csicl,csics, - & rsihl,rsihs,rsicl,rsics, - & qsihl,qsihs,qsicl,qsics - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, & + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, & + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, & + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, & + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, & + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, & + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, & + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, & + & cvets,calfs,deltsfc, & + & csihl,csihs,csicl,csics, & + & rsihl,rsihs,rsicl,rsics, & + & qsihl,qsihs,qsicl,qsics & + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps & + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs & + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2) - &, sihfcs(len), sicfcs(len) + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & + & zorfcs(len), albfcs(len,4), aisfcs(len), & + & cvfcs (len), cvbfcs(len), cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len), vegfcs(len), & + & vetfcs(len), sotfcs(len), alffcs(len,2) & + &, sihfcs(len), sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), - & wetanl(len),snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2) - &, sihanl(len),sicanl(len) + real (kind=kind_io8) tsfanl(len),tsfan2(len), & + & wetanl(len),snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), & & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), & & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & & qstcl(lsoil), qstcs(lsoil) logical first integer num_threads @@ -5074,18 +5057,17 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, end subroutine merge !>\ingroup mod_sfcsub - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & sihnew,sicnew,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albsea,snosea,zorsea,smcsea,smcice, - & tsfmin,tsfice,albice,zorice,tgice, + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & + & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & albanl,snoanl,zoranl,smcanl,stcanl, & + & albsea,snosea,zorsea,smcsea,smcice, & + & tsfmin,tsfice,albice,zorice,tgice, & & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, & & smcice,tsfmin,zorsea,smcsea !cwu [+1l] add sicnew,sihnew &, sicnew,sihnew @@ -5172,7 +5154,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, end !>\ingroup mod_sfcsub - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & & landice,me) use machine , only : kind_io8,kind_io4 implicit none @@ -5220,14 +5202,14 @@ subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, end subroutine qcsnow !>\ingroup mod_sfcsub - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & & rla,rlo,len,me) use machine , only : kind_io8,kind_io4 implicit none integer kount1,kount,i,me,len real (kind=kind_io8) per,aicsea,aicice,sllnd ! - real (kind=kind_io8) ais(len), glacir(len), + real (kind=kind_io8) ais(len), glacir(len), & & amxice(len), slmask(len) real (kind=kind_io8) rla(len), rlo(len) ! @@ -5353,23 +5335,23 @@ subroutine scale(fld,len,scl) end !>\ingroup mod_sfcsub - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, & + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, & & rla,rlo,len,mode,percrit,lgchek,me) ! use machine , only : kind_io8,kind_io4 implicit none - real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, - & fldlmx,fldlmn,fldomx,fldjmn,percrit, + real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, & + & fldlmx,fldlmn,fldomx,fldjmn,percrit, & & fldsmx,fldsmn,epsfld - integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, + integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, & & ij,nprt,kmaxs,kmins,i,me,len,mode parameter(mmprt=2) ! character*8 ttl logical iceflg(len) - real (kind=kind_io8) fld(len),slimsk(len),sno(len), + real (kind=kind_io8) fld(len),slimsk(len),sno(len), & & rla(len), rlo(len) integer iwk(len) logical lgchek @@ -5856,7 +5838,7 @@ subroutine getsmc(wetfld,len,lsoil,smcfld,me) end !>\ingroup mod_sfcsub - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, & & tsfimx) ! use machine , only : kind_io8,kind_io4 @@ -6012,9 +5994,9 @@ subroutine qcsli(slianl,slifcs,len,me) ! end !>\ingroup mod_sfcsub - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & + & zoranl,smcanl, & & smcclm,tsfsmx,albomx,zoromx, me) ! use machine , only : kind_io8,kind_io4 @@ -6110,8 +6092,8 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, end !>\ingroup mod_sfcsub - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, - & data,imax,jmax,rlnout,rltout,lmask,rslmsk + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & + & data,imax,jmax,rlnout,rltout,lmask,rslmsk & &, gaus,blno, blto, kgds1, kpds4, lbms) use machine , only : kind_io8,kind_io4 use sfccyc_module @@ -6586,25 +6568,26 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, end !>\ingroup mod_sfcsub - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, +!! This subroutine interpolates from lat/lon grid to other lat/lon grid. + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & & wlon,rnlat,rlnout,rltout,gaus,blno, blto) use machine , only : kind_io8,kind_io4 implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, - & rnlat,dxout,dphi,dlat,facns,tem,blno, + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, & + & rnlat,dxout,dphi,dlat,facns,tem,blno, & & blto ! ! interpolation from lat/lon grid to other lat/lon grid ! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) & &, rlnout(imxout), rltout(jmxout) logical gaus ! real, allocatable :: gaul(:) real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), + integer iindx1(imxout), iindx2(imxout), & & jindx1(jmxout), jindx2(jmxout) integer jmxsav,n,kspla data jmxsav/0/ @@ -6838,8 +6821,8 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) - +, slptype(len) + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & + &, slptype(len) ! ! make sure that the soil type and veg type are non-zero over land ! @@ -6852,8 +6835,9 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) enddo return -!>\ingroup mod_sfcsub end subroutine landtyp + +!>\ingroup mod_sfcsub subroutine gaulat(gaul,k) ! use machine , only : kind_io8,kind_io4 @@ -6886,7 +6870,7 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), + real (kind=kind_io8) tsfanl(len), tsfan0(len), & & tsfclm(len), tsfcl0(len) ! ! time interpolation of anomalies @@ -6900,53 +6884,53 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) end !>\ingroup mod_sfcsub - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc, & + & fnvmnc,fnvmxc,fnslpc,fnabsc, & + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,& + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,& + & vetclm,sotclm,alfclm, & + & vmnclm,vmxclm,slpclm,absclm, & + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & + & kpdvet,kpdsot,kpdalf,tsfcl0, & + & kpdvmn,kpdvmx,kpdslp,kpdabs, & + & deltsfc, lanom & + &, imsk, jmsk, slmskh, outlat, outlon & + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb & &, tile_num_ch, i_index, j_index) ! use machine , only : kind_io8,kind_io4 implicit none character(len=*), intent(in) :: tile_num_ch integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, & & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, & + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, & + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, & + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, & + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb & &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat integer kpdalb(4), kpdalf(2) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc,fnalbc2 + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc,fnalbc2 & &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), - & wetclm(len),snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len),acnclm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) + real (kind=kind_io8) tsfclm(len),tsfcl2(len), & + & wetclm(len),snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len),acnclm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) @@ -8068,8 +8052,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, end subroutine clima !>\ingroup mod_sfcsub - subroutine fixrdc_tile(filename_raw, tile_num_ch, - & i_index, j_index, kpds, + subroutine fixrdc_tile(filename_raw, tile_num_ch, & + & i_index, j_index, kpds, & & var, mon, npts, me) use netcdf use machine , only : kind_io8 @@ -8222,22 +8206,21 @@ subroutine netcdf_err(error) end subroutine netcdf_err !>\ingroup mod_sfcsub - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, - & gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto +!! reads in grib climatology files and interpolate to the input +!! grid. grib files should allow all the necessary parameters +!! to be extracted from the description records. + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & + & gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, & + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami & &, jj,w3kindreal,w3kindint real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto ! -! read in grib climatology files and interpolate to the input -! grid. grib files should allow all the necessary parameters -! to be extracted from the description records. -! ! character*500 fngrib ! character*80 fngrib, asgnstr @@ -8400,18 +8383,18 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, end subroutine fixrdc !>\ingroup mod_sfcsub - subroutine fixrda(lugb,fngrib,kpds5,slmask, - & iy,im,id,ih,fh,gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto + subroutine fixrda(lugb,fngrib,kpds5,slmask, & + & iy,im,id,ih,fh,gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! ! read in grib climatology/analysis files and interpolate to the input From b170021b7ece53d6bcdc1a092faa36f9f6f019af Mon Sep 17 00:00:00 2001 From: "Man.Zhang" Date: Thu, 27 Jun 2019 14:01:55 -0600 Subject: [PATCH 15/19] minor format changes --- physics/sfcsub.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 391256ce0..7039884f8 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -6821,7 +6821,7 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & &, slptype(len) ! ! make sure that the soil type and veg type are non-zero over land From c015a4ea5e28c8e6b95ae1c9ffb57075eaf3d395 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Thu, 27 Jun 2019 22:37:45 -0600 Subject: [PATCH 16/19] physics/gfdl_cloud_microphys.F90: update metadata --- physics/gfdl_cloud_microphys.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 8e6f645ca..903175572 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -160,7 +160,7 @@ end subroutine gfdl_cloud_microphys_finalize !! | lradar | flag_for_radar_reflectivity | flag for radar reflectivity | flag | 0 | logical | | in | F | !! | refl_10cm | radar_reflectivity_10cm | instantaneous refl_10cm | dBZ | 2 | real | kind_phys | inout | F | !! | reset | flag_reset_maximum_hourly_fields | flag for resetting maximum hourly fields | flag | 0 | logical | | in | F | -!! | effr_in | flag_for_cloud_effective_radii | flag for cloud effective radii calculations in microphysics | | 0 | logical | | in | F | +!! | effr_in | flag_for_cloud_effective_radii | flag for cloud effective radii calculations in GFDL microphysics | | 0 | logical | | in | F | !! | rew | effective_radius_of_stratiform_cloud_liquid_water_particle_in_um | eff. radius of cloud liquid water particle in micrometer | um | 2 | real | kind_phys | inout | F | !! | rei | effective_radius_of_stratiform_cloud_ice_particle_in_um | eff. radius of cloud ice water particle in micrometer | um | 2 | real | kind_phys | inout | F | !! | rer | effective_radius_of_stratiform_cloud_rain_particle_in_um | effective radius of cloud rain particle in micrometers | um | 2 | real | kind_phys | inout | F | From 1e9d51a84a13fa175d3a7ff1ce86c9a255b07701 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Thu, 27 Jun 2019 22:38:13 -0600 Subject: [PATCH 17/19] physics/sfc_drv_ruc.F90: update metadata and rename wet1 to wetness --- physics/sfc_drv_ruc.F90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 3b0e64637..77833671f 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -134,7 +134,7 @@ end subroutine lsm_ruc_finalize ! sbsno - real, sublimation/deposit from snopack (m/s) im ! ! stm - real, total soil column moisture content (m) im ! ! zorl - real, surface roughness im ! -! wet1 - real, normalized soil wetness im ! +! wetness - real, normalized soil wetness im ! ! ! ! ==================== end of description ===================== ! @@ -193,7 +193,7 @@ end subroutine lsm_ruc_finalize !! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air_over_land | surface exchange coeff heat & moisture over land | none | 1 | real | kind_phys | in | F | !! | chh | surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land | thermal exchange coefficient over land | kg m-2 s-1 | 1 | real | kind_phys | inout | F | !! | cmm | surface_drag_wind_speed_for_momentum_in_air_over_land | momentum exchange coefficient over land | m s-1 | 1 | real | kind_phys | inout | F | -!! | wet1 | normalized_soil_wetness | normalized soil wetness | frac | 1 | real | kind_phys | inout | F | +!! | wetness | normalized_soil_wetness_for_land_surface_model | normalized soil wetness | frac | 1 | real | kind_phys | inout | F | !! | canopy | canopy_water_amount | canopy water amount | kg m-2 | 1 | real | kind_phys | inout | F | !! | sigmaf | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | !! | sfalb | surface_diffused_shortwave_albedo | mean surface diffused sw albedo | frac | 1 | real | kind_phys | inout | F | @@ -267,7 +267,7 @@ subroutine lsm_ruc_run & ! --- inpu & sfcqc, sfcdew, tice, sfcqv, & & sncovr1, qsurf, gflux, drain, evap, hflx, & ! --- outputs & rhosnf, runof, runoff, srunoff, & - & chh, cmm, evbs, evcw, sbsno, stm, wet1, & + & chh, cmm, evbs, evcw, sbsno, stm, wetness, & & acsnow, snowfallac, & & flag_init, flag_restart, errmsg, errflg & & ) @@ -319,7 +319,7 @@ subroutine lsm_ruc_run & ! --- inpu real (kind=kind_phys), dimension(im), intent(inout) :: sncovr1, & & qsurf , gflux , evap , runof , drain , & & runoff, srunoff, hflx, cmm, chh, & - & rhosnf, evbs, evcw, sbsno, stm, wet1, & + & rhosnf, evbs, evcw, sbsno, stm, wetness, & & acsnow, snowfallac logical, intent(in) :: flag_init, flag_restart @@ -331,7 +331,7 @@ subroutine lsm_ruc_run & ! --- inpu & q0, qs1, wind, weasd_old, snwdph_old, & & tprcp_old, srflag_old, sr_old, tskin_old, canopy_old, & & tsnow_old, snowfallac_old, acsnow_old, sfalb_old, & - & sfcqv_old, sfcqc_old, wet1_old, zorl_old, sncovr1_old + & sfcqv_old, sfcqc_old, wetness_old, zorl_old, sncovr1_old real (kind=kind_phys), dimension(lsoil_ruc) :: et @@ -426,7 +426,7 @@ subroutine lsm_ruc_run & ! --- inpu smc, slc, stc, & ! in smcref2, smcwlt2, & ! inout lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, wet1, & ! out + zs, sh2o, smfrkeep, tslb, smois, wetness, & ! out errmsg, errflg) !do i = 1, im ! n - horizontal loop @@ -521,7 +521,7 @@ subroutine lsm_ruc_run & ! --- inpu sfalb_old(i) = sfalb(i) sfcqv_old(i) = sfcqv(i) sfcqc_old(i) = sfcqc(i) - wet1_old(i) = wet1(i) + wetness_old(i) = wetness(i) zorl_old(i) = zorl(i) sncovr1_old(i) = sncovr1(i) do k = 1, lsoil_ruc @@ -777,8 +777,8 @@ subroutine lsm_ruc_run & ! --- inpu if(stype(i,j) .ne. 14) then ! land - if (wet1(i) > 0.) then - wet(i,j) = wet1(i) + if (wetness(i) > 0.) then + wet(i,j) = wetness(i) else wet(i,j) = max(0.0001,smsoil(i,1,j)/0.3) endif @@ -1034,7 +1034,7 @@ subroutine lsm_ruc_run & ! --- inpu runof (i) = runoff1(i,j) drain (i) = runoff2(i,j) - wet1(i) = wet(i,j) + wetness(i) = wet(i,j) ! State variables tsnow(i) = soilt1(i,j) @@ -1111,7 +1111,7 @@ subroutine lsm_ruc_run & ! --- inpu sfalb(i) = sfalb_old(i) sfcqv(i) = sfcqv_old(i) sfcqc(i) = sfcqc_old(i) - wet1(i) = wet1_old(i) + wetness(i) = wetness_old(i) zorl(i) = zorl_old(i) sncovr1(i) = sncovr1_old(i) do k = 1, lsoil_ruc @@ -1157,8 +1157,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in smc, slc, stc, & ! in smcref2, smcwlt2, & ! inout lsm_ruc, lsm, & ! in - zs, sh2o, smfrkeep, tslb, smois, wet1, & ! out - errmsg, errflg) + zs, sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) implicit none @@ -1180,7 +1180,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in integer, dimension(im), intent(inout) :: soiltyp integer, dimension(im), intent(inout) :: vegtype - real (kind=kind_phys), dimension(im), intent(inout) :: wet1 + real (kind=kind_phys), dimension(im), intent(inout) :: wetness real (kind=kind_phys), dimension(im), intent(inout) :: fice real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc @@ -1502,7 +1502,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in do j=jts,jte do i=its,ite - wet1(i) = mavail(i,j) + wetness(i) = mavail(i,j) do k = 1, lsoil_ruc smois(i,k) = soilm(i,k,j) tslb(i,k) = soiltemp(i,k,j) From 04fe39a8fe673de65e913f62c94ce1363ad86715 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 28 Jun 2019 13:22:05 -0600 Subject: [PATCH 18/19] physics/sfc_drv_ruc.F90: remove sr and use srflag, together with information about the MP physics scheme --- physics/sfc_drv_ruc.F90 | 258 ++++++++++++++++++++-------------------- 1 file changed, 131 insertions(+), 127 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 77833671f..d4e15a7f7 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -114,8 +114,8 @@ end subroutine lsm_ruc_finalize ! snwdph - real, snow depth (water equiv) over land im ! ! tskin - real, ground surface skin temperature ( k ) im ! ! tprcp - real, total precipitation im ! -! srflag - real, snow/rain flag for precipitation im ! -! sr - real, mixed-phase precipitation fraction im ! +! srflag - real, snow/rain flag for precipitation or mixed-phase +! precipitation fraction (depends on MP) im ! ! tslb - real, soil temp (k) im,km ! ! sh2o - real, liquid soil moisture im,km ! ! canopy - real, canopy moisture content (mm) im ! @@ -142,130 +142,133 @@ end subroutine lsm_ruc_finalize !! This module contains GSD RUC Land Surface Model #if 0 !> \section arg_table_lsm_ruc_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |-----------------|------------------------------------------------------------------------------|-----------------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| -!! | delt | time_step_for_dynamics | physics time step | s | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | kdt | index_of_time_step | current number of time steps | index | 0 | integer | | in | F | -!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | nlev | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | -!! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | -!! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | -!! | do_mynnsfclay | do_mynnsfclay | flag to activate MYNN surface layer | flag | 0 | logical | | in | F | -!! | lsoil_ruc | soil_vertical_dimension_for_land_surface_model | number of soil layers internal to land surface model | count | 0 | integer | | in | F | -!! | lsoil | soil_vertical_dimension | soil vertical layer dimension | count | 0 | integer | | in | F | -!! | zs | depth_of_soil_levels_for_land_surface_model | depth of soil levels for land surface model | m | 1 | real | kind_phys | inout | F | -!! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat !of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of vaporization/sublimation (hvap) | J kg-1 | 0 | real | kind_phys | in | F | -!! | con_fvirt | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | land | flag_nonzero_land_surface_fraction | flag indicating presence of some land surface area fraction | flag | 1 | logical | | in | F | -!! | rainnc | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | in | F | -!! | rainc | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | in | F | -!! | ice | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | in | F | -!! | snow | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | in | F | -!! | graupel | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | in | F | -!! | srflag | flag_for_precipitation_type | snow/rain flag for precipitation | flag | 1 | real | kind_phys | in | F | -!! | sncovr1 | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | -!! | weasd | water_equivalent_accumulated_snow_depth_over_land | water equiv of acc snow depth over land | mm | 1 | real | kind_phys | inout | F | -!! | snwdph | surface_snow_thickness_water_equivalent_over_land | water equivalent snow depth over land | mm | 1 | real | kind_phys | inout | F | -!! | sr | ratio_of_snowfall_to_rainfall | snow ratio: ratio of snow to total precipitation | frac | 1 | real | kind_phys | in | F | -!! | rhosnf | density_of_frozen_precipitation | density of frozen precipitation | kg m-3 | 1 | real | kind_phys | out | F | -!! | zf | height_above_ground_at_lowest_model_layer | layer 1 height above ground (not MSL) | m | 1 | real | kind_phys | in | F | -!! | u1 | x_wind_at_lowest_model_layer | zonal wind at lowest model layer | m s-1 | 1 | real | kind_phys | in | F | -!! | v1 | y_wind_at_lowest_model_layer | meridional wind at lowest model layer | m s-1 | 1 | real | kind_phys | in | F | -!! | prsl1 | air_pressure_at_lowest_model_layer | mean pressure at lowest model layer | Pa | 1 | real | kind_phys | in | F | -!! | ddvel | surface_wind_enhancement_due_to_convection | surface wind enhancement due to convection | m s-1 | 1 | real | kind_phys | in | F | -!! | t1 | air_temperature_at_lowest_model_layer | mean temperature at lowest model layer | K | 1 | real | kind_phys | in | F | -!! | q1 | water_vapor_specific_humidity_at_lowest_model_layer | water vapor specific humidity at lowest model layer | kg kg-1 | 1 | real | kind_phys | in | F | -!! | qc | cloud_condensed_water_mixing_ratio_at_lowest_model_layer | moist (dry+vapor, no condensates) mixing ratio of cloud water at lowest model layer | kg kg-1 | 1 | real | kind_phys | in | F | -!! | dlwflx | surface_downwelling_longwave_flux | surface downwelling longwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | -!! | dswsfc | surface_downwelling_shortwave_flux | surface downwelling shortwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | -!! | snet | surface_net_downwelling_shortwave_flux | surface net downwelling shortwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | -!! | sfcemis | surface_longwave_emissivity | surface lw emissivity in fraction | frac | 1 | real | kind_phys | inout | F | -!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | inout | F | -!! | cm | surface_drag_coefficient_for_momentum_in_air_over_land | surface exchange coeff for momentum over land | none | 1 | real | kind_phys | in | F | -!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air_over_land | surface exchange coeff heat & moisture over land | none | 1 | real | kind_phys | in | F | -!! | chh | surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land | thermal exchange coefficient over land | kg m-2 s-1 | 1 | real | kind_phys | inout | F | -!! | cmm | surface_drag_wind_speed_for_momentum_in_air_over_land | momentum exchange coefficient over land | m s-1 | 1 | real | kind_phys | inout | F | -!! | wetness | normalized_soil_wetness_for_land_surface_model | normalized soil wetness | frac | 1 | real | kind_phys | inout | F | -!! | canopy | canopy_water_amount | canopy water amount | kg m-2 | 1 | real | kind_phys | inout | F | -!! | sigmaf | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | -!! | sfalb | surface_diffused_shortwave_albedo | mean surface diffused sw albedo | frac | 1 | real | kind_phys | inout | F | -!! | alvwf | mean_vis_albedo_with_weak_cosz_dependency | mean vis albedo with weak cosz dependency | frac | 1 | real | kind_phys | in | F | -!! | alnwf | mean_nir_albedo_with_weak_cosz_dependency | mean nir albedo with weak cosz dependency | frac | 1 | real | kind_phys | in | F | -!! | snoalb | upper_bound_on_max_albedo_over_deep_snow | maximum snow albedo | frac | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length_over_land_interstitial | surface roughness length over land (temporary use as interstitial)| cm | 1 | real | kind_phys | inout | F | -!! | qsurf | surface_specific_humidity_over_land | surface air saturation specific humidity over land | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | sfcqc | cloud_condensed_water_mixing_ratio_at_surface | moist cloud water mixing ratio at surface | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | sfcqv | water_vapor_mixing_ratio_at_surface | water vapor mixing ratio at surface | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | sfcdew | surface_condensation_mass | surface condensation mass | kg m-2 | 1 | real | kind_phys | inout | F | -!! | tg3 | deep_soil_temperature | deep soil temperature | K | 1 | real | kind_phys | in | F | -!! | smc | volume_fraction_of_soil_moisture | total soil moisture | frac | 2 | real | kind_phys | inout | F | -!! | slc | volume_fraction_of_unfrozen_soil_moisture | liquid soil moisture | frac | 2 | real | kind_phys | inout | F | -!! | stc | soil_temperature | soil temperature | K | 2 | real | kind_phys | inout | F | -!! | smcwlt2 | volume_fraction_of_condensed_water_in_soil_at_wilting_point | soil water fraction at wilting point | frac | 1 | real | kind_phys | inout | F | -!! | smcref2 | threshold_volume_fraction_of_condensed_water_in_soil | soil moisture threshold | frac | 1 | real | kind_phys | inout | F | -!! | vegtype | vegetation_type_classification | vegetation type at each grid cell | index | 1 | integer | | in | F | -!! | soiltyp | soil_type_classification | soil type at each grid cell | index | 1 | integer | | in | F | -!! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | -!! | ivegsrc | vegetation_type_dataset_choice | land use dataset choice | index | 0 | integer | | in | F | -!! | fice | sea_ice_concentration | ice fraction over open water | frac | 1 | real | kind_phys | in | F | -!! | keepfr | flag_for_frozen_soil_physics | flag for frozen soil physics (RUC) | flag | 2 | real | kind_phys | inout | F | -!! | smois | volume_fraction_of_soil_moisture_for_land_surface_model | volumetric fraction of soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | -!! | sh2o | volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model | volume fraction of unfrozen soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | -!! | smfrkeep | volume_fraction_of_frozen_soil_moisture_for_land_surface_model | volume fraction of frozen soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | -!! | tslb | soil_temperature_for_land_surface_model | soil temperature for land surface model | K | 2 | real | kind_phys | inout | F | -!! | stm | soil_moisture_content | soil moisture content | kg m-2 | 1 | real | kind_phys | inout | F | -!! | tskin | surface_skin_temperature_over_land_interstitial | surface skin temperature over land use as interstitial | K | 1 | real | kind_phys | inout | F | -!! | tsurf | surface_skin_temperature_after_iteration_over_land | surface skin temperature after iteration over land | K | 1 | real | kind_phys | inout | F | -!! | tice | sea_ice_temperature_interstitial | sea ice surface skin temperature use as interstitial | K | 1 | real | kind_phys | inout | F | -!! | tsnow | snow_temperature_bottom_first_layer | snow temperature at the bottom of first snow layer | K | 1 | real | kind_phys | inout | F | -!! | snowfallac | total_accumulated_snowfall | run-total snow accumulation on the ground | kg m-2 | 1 | real | kind_phys | inout | F | -!! | acsnow | accumulated_water_equivalent_of_frozen_precip | snow water equivalent of run-total frozen precip | kg m-2 | 1 | real | kind_phys | inout | F | -!! | evap | kinematic_surface_upward_latent_heat_flux_over_land | kinematic surface upward evaporation flux over land | kg kg-1 m s-1 | 1 | real | kind_phys | out | F | -!! | hflx | kinematic_surface_upward_sensible_heat_flux_over_land | kinematic surface upward sensible heat flux over land | K m s-1 | 1 | real | kind_phys | out | F | -!! | evbs | soil_upward_latent_heat_flux | soil upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | evcw | canopy_upward_latent_heat_flux | canopy upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | sbsno | snow_deposition_sublimation_upward_latent_heat_flux | latent heat flux from snow depo/subl | W m-2 | 1 | real | kind_phys | out | F | -!! | trans | transpiration_flux | total plant transpiration rate | kg m-2 s-1 | 1 | real | kind_phys | out | F | -!! | runof | surface_runoff_flux | surface runoff flux | g m-2 s-1 | 1 | real | kind_phys | out | F | -!! | drain | subsurface_runoff_flux | subsurface runoff flux | g m-2 s-1 | 1 | real | kind_phys | out | F | -!! | runoff | total_runoff | total water runoff | kg m-2 | 1 | real | kind_phys | inout | F | -!! | srunoff | surface_runoff | surface water runoff (from lsm) | kg m-2 | 1 | real | kind_phys | inout | F | -!! | gflux | upward_heat_flux_in_soil_over_land | soil heat flux over land | W m-2 | 1 | real | kind_phys | out | F | -!! | shdmin | minimum_vegetation_area_fraction | min fractional coverage of green vegetation | frac | 1 | real | kind_phys | in | F | -!! | shdmax | maximum_vegetation_area_fraction | max fractional coverage of green vegetation | frac | 1 | real | kind_phys | in | F | -!! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | -!! | flag_guess | flag_for_guess_run | flag for guess run | flag | 1 | logical | | in | F | -!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | -!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------------|------------------------------------------------------------------------------|-----------------------------------------------------------------|---------------|------|-----------|-----------|--------|----------| +!! | delt | time_step_for_dynamics | physics time step | s | 0 | real | kind_phys | in | F | +!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | +!! | kdt | index_of_time_step | current number of time steps | index | 0 | integer | | in | F | +!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | nlev | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | +!! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | +!! | imp_physics | flag_for_microphysics_scheme | choice of microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_gfdl | flag_for_gfdl_microphysics_scheme | choice of GFDL microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_thompson | flag_for_thompson_microphysics_scheme | choice of Thompson microphysics scheme | flag | 0 | integer | | in | F | +!! | do_mynnsfclay | do_mynnsfclay | flag to activate MYNN surface layer | flag | 0 | logical | | in | F | +!! | lsoil_ruc | soil_vertical_dimension_for_land_surface_model | number of soil layers internal to land surface model | count | 0 | integer | | in | F | +!! | lsoil | soil_vertical_dimension | soil vertical layer dimension | count | 0 | integer | | in | F | +!! | zs | depth_of_soil_levels_for_land_surface_model | depth of soil levels for land surface model | m | 1 | real | kind_phys | inout | F | +!! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | +!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat !of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | con_pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | +!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | con_hvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of vaporization/sublimation (hvap) | J kg-1 | 0 | real | kind_phys | in | F | +!! | con_fvirt | ratio_of_vapor_to_dry_air_gas_constants_minus_one | rv/rd - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | land | flag_nonzero_land_surface_fraction | flag indicating presence of some land surface area fraction | flag | 1 | logical | | in | F | +!! | rainnc | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | in | F | +!! | rainc | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | in | F | +!! | ice | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | in | F | +!! | snow | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | in | F | +!! | graupel | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | in | F | +!! | srflag | flag_for_precipitation_type | snow/rain flag for precipitation | flag | 1 | real | kind_phys | in | F | +!! | sncovr1 | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | +!! | weasd | water_equivalent_accumulated_snow_depth_over_land | water equiv of acc snow depth over land | mm | 1 | real | kind_phys | inout | F | +!! | snwdph | surface_snow_thickness_water_equivalent_over_land | water equivalent snow depth over land | mm | 1 | real | kind_phys | inout | F | +!! | rhosnf | density_of_frozen_precipitation | density of frozen precipitation | kg m-3 | 1 | real | kind_phys | out | F | +!! | zf | height_above_ground_at_lowest_model_layer | layer 1 height above ground (not MSL) | m | 1 | real | kind_phys | in | F | +!! | u1 | x_wind_at_lowest_model_layer | zonal wind at lowest model layer | m s-1 | 1 | real | kind_phys | in | F | +!! | v1 | y_wind_at_lowest_model_layer | meridional wind at lowest model layer | m s-1 | 1 | real | kind_phys | in | F | +!! | prsl1 | air_pressure_at_lowest_model_layer | mean pressure at lowest model layer | Pa | 1 | real | kind_phys | in | F | +!! | ddvel | surface_wind_enhancement_due_to_convection | surface wind enhancement due to convection | m s-1 | 1 | real | kind_phys | in | F | +!! | t1 | air_temperature_at_lowest_model_layer | mean temperature at lowest model layer | K | 1 | real | kind_phys | in | F | +!! | q1 | water_vapor_specific_humidity_at_lowest_model_layer | water vapor specific humidity at lowest model layer | kg kg-1 | 1 | real | kind_phys | in | F | +!! | qc | cloud_condensed_water_mixing_ratio_at_lowest_model_layer | moist (dry+vapor, no condensates) mixing ratio of cloud water at lowest model layer | kg kg-1 | 1 | real | kind_phys | in | F | +!! | dlwflx | surface_downwelling_longwave_flux | surface downwelling longwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | +!! | dswsfc | surface_downwelling_shortwave_flux | surface downwelling shortwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | +!! | snet | surface_net_downwelling_shortwave_flux | surface net downwelling shortwave flux at current time | W m-2 | 1 | real | kind_phys | in | F | +!! | sfcemis | surface_longwave_emissivity | surface lw emissivity in fraction | frac | 1 | real | kind_phys | inout | F | +!! | wspd | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | inout | F | +!! | cm | surface_drag_coefficient_for_momentum_in_air_over_land | surface exchange coeff for momentum over land | none | 1 | real | kind_phys | in | F | +!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air_over_land | surface exchange coeff heat & moisture over land | none | 1 | real | kind_phys | in | F | +!! | chh | surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land | thermal exchange coefficient over land | kg m-2 s-1 | 1 | real | kind_phys | inout | F | +!! | cmm | surface_drag_wind_speed_for_momentum_in_air_over_land | momentum exchange coefficient over land | m s-1 | 1 | real | kind_phys | inout | F | +!! | wetness | normalized_soil_wetness_for_land_surface_model | normalized soil wetness | frac | 1 | real | kind_phys | inout | F | +!! | canopy | canopy_water_amount | canopy water amount | kg m-2 | 1 | real | kind_phys | inout | F | +!! | sigmaf | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | +!! | sfalb | surface_diffused_shortwave_albedo | mean surface diffused sw albedo | frac | 1 | real | kind_phys | inout | F | +!! | alvwf | mean_vis_albedo_with_weak_cosz_dependency | mean vis albedo with weak cosz dependency | frac | 1 | real | kind_phys | in | F | +!! | alnwf | mean_nir_albedo_with_weak_cosz_dependency | mean nir albedo with weak cosz dependency | frac | 1 | real | kind_phys | in | F | +!! | snoalb | upper_bound_on_max_albedo_over_deep_snow | maximum snow albedo | frac | 1 | real | kind_phys | in | F | +!! | zorl | surface_roughness_length_over_land_interstitial | surface roughness length over land (temporary use as interstitial)| cm | 1 | real | kind_phys | inout | F | +!! | qsurf | surface_specific_humidity_over_land | surface air saturation specific humidity over land | kg kg-1 | 1 | real | kind_phys | inout | F | +!! | sfcqc | cloud_condensed_water_mixing_ratio_at_surface | moist cloud water mixing ratio at surface | kg kg-1 | 1 | real | kind_phys | inout | F | +!! | sfcqv | water_vapor_mixing_ratio_at_surface | water vapor mixing ratio at surface | kg kg-1 | 1 | real | kind_phys | inout | F | +!! | sfcdew | surface_condensation_mass | surface condensation mass | kg m-2 | 1 | real | kind_phys | inout | F | +!! | tg3 | deep_soil_temperature | deep soil temperature | K | 1 | real | kind_phys | in | F | +!! | smc | volume_fraction_of_soil_moisture | total soil moisture | frac | 2 | real | kind_phys | inout | F | +!! | slc | volume_fraction_of_unfrozen_soil_moisture | liquid soil moisture | frac | 2 | real | kind_phys | inout | F | +!! | stc | soil_temperature | soil temperature | K | 2 | real | kind_phys | inout | F | +!! | smcwlt2 | volume_fraction_of_condensed_water_in_soil_at_wilting_point | soil water fraction at wilting point | frac | 1 | real | kind_phys | inout | F | +!! | smcref2 | threshold_volume_fraction_of_condensed_water_in_soil | soil moisture threshold | frac | 1 | real | kind_phys | inout | F | +!! | vegtype | vegetation_type_classification | vegetation type at each grid cell | index | 1 | integer | | in | F | +!! | soiltyp | soil_type_classification | soil type at each grid cell | index | 1 | integer | | in | F | +!! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | +!! | ivegsrc | vegetation_type_dataset_choice | land use dataset choice | index | 0 | integer | | in | F | +!! | fice | sea_ice_concentration | ice fraction over open water | frac | 1 | real | kind_phys | in | F | +!! | keepfr | flag_for_frozen_soil_physics | flag for frozen soil physics (RUC) | flag | 2 | real | kind_phys | inout | F | +!! | smois | volume_fraction_of_soil_moisture_for_land_surface_model | volumetric fraction of soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | +!! | sh2o | volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model | volume fraction of unfrozen soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | +!! | smfrkeep | volume_fraction_of_frozen_soil_moisture_for_land_surface_model | volume fraction of frozen soil moisture for lsm | frac | 2 | real | kind_phys | inout | F | +!! | tslb | soil_temperature_for_land_surface_model | soil temperature for land surface model | K | 2 | real | kind_phys | inout | F | +!! | stm | soil_moisture_content | soil moisture content | kg m-2 | 1 | real | kind_phys | inout | F | +!! | tskin | surface_skin_temperature_over_land_interstitial | surface skin temperature over land use as interstitial | K | 1 | real | kind_phys | inout | F | +!! | tsurf | surface_skin_temperature_after_iteration_over_land | surface skin temperature after iteration over land | K | 1 | real | kind_phys | inout | F | +!! | tice | sea_ice_temperature_interstitial | sea ice surface skin temperature use as interstitial | K | 1 | real | kind_phys | inout | F | +!! | tsnow | snow_temperature_bottom_first_layer | snow temperature at the bottom of first snow layer | K | 1 | real | kind_phys | inout | F | +!! | snowfallac | total_accumulated_snowfall | run-total snow accumulation on the ground | kg m-2 | 1 | real | kind_phys | inout | F | +!! | acsnow | accumulated_water_equivalent_of_frozen_precip | snow water equivalent of run-total frozen precip | kg m-2 | 1 | real | kind_phys | inout | F | +!! | evap | kinematic_surface_upward_latent_heat_flux_over_land | kinematic surface upward evaporation flux over land | kg kg-1 m s-1 | 1 | real | kind_phys | out | F | +!! | hflx | kinematic_surface_upward_sensible_heat_flux_over_land | kinematic surface upward sensible heat flux over land | K m s-1 | 1 | real | kind_phys | out | F | +!! | evbs | soil_upward_latent_heat_flux | soil upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | evcw | canopy_upward_latent_heat_flux | canopy upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | +!! | sbsno | snow_deposition_sublimation_upward_latent_heat_flux | latent heat flux from snow depo/subl | W m-2 | 1 | real | kind_phys | out | F | +!! | trans | transpiration_flux | total plant transpiration rate | kg m-2 s-1 | 1 | real | kind_phys | out | F | +!! | runof | surface_runoff_flux | surface runoff flux | g m-2 s-1 | 1 | real | kind_phys | out | F | +!! | drain | subsurface_runoff_flux | subsurface runoff flux | g m-2 s-1 | 1 | real | kind_phys | out | F | +!! | runoff | total_runoff | total water runoff | kg m-2 | 1 | real | kind_phys | inout | F | +!! | srunoff | surface_runoff | surface water runoff (from lsm) | kg m-2 | 1 | real | kind_phys | inout | F | +!! | gflux | upward_heat_flux_in_soil_over_land | soil heat flux over land | W m-2 | 1 | real | kind_phys | out | F | +!! | shdmin | minimum_vegetation_area_fraction | min fractional coverage of green vegetation | frac | 1 | real | kind_phys | in | F | +!! | shdmax | maximum_vegetation_area_fraction | max fractional coverage of green vegetation | frac | 1 | real | kind_phys | in | F | +!! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | +!! | flag_guess | flag_for_guess_run | flag for guess run | flag | 1 | logical | | in | F | +!! | flag_init | flag_for_first_time_step | flag signaling first time step for time integration loop | flag | 0 | logical | | in | F | +!! | flag_restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif !>\section gen_lsmruc GSD RUC LSM General Algorithm - subroutine lsm_ruc_run & ! --- inputs +! DH* TODO - make order of arguments the same as in the metadata table + subroutine lsm_ruc_run & ! inputs & ( iter, me, kdt, im, nlev, lsoil_ruc, lsoil, zs, & & u1, v1, t1, q1, qc, soiltyp, vegtype, sigmaf, & & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & & prsl1, zf, islmsk, ddvel, shdmin, shdmax, alvwf, alnwf, & & snoalb, sfalb, flag_iter, flag_guess, isot, ivegsrc, fice, & & smc, stc, slc, lsm_ruc, lsm, land, & + & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & smcwlt2, smcref2, wspd, do_mynnsfclay, & - & con_cp, con_rv, con_rd, con_g, con_pi, con_hvap, con_fvirt,& ! constants - & weasd, snwdph, tskin, & ! in/outs + & con_cp, con_rv, con_rd, con_g, con_pi, con_hvap, con_fvirt,& ! constants + & weasd, snwdph, tskin, & ! in/outs & rainnc, rainc, ice, snow, graupel, & ! in - & srflag, sr, & ! in/outs - & smois, tslb, sh2o, keepfr, smfrkeep, & ! on RUC levels + & srflag, smois, tslb, sh2o, keepfr, smfrkeep, & ! in/outs, on RUC levels & canopy, trans, tsurf, tsnow, zorl, & & sfcqc, sfcdew, tice, sfcqv, & - & sncovr1, qsurf, gflux, drain, evap, hflx, & ! --- outputs + & sncovr1, qsurf, gflux, drain, evap, hflx, & ! outputs & rhosnf, runof, runoff, srunoff, & & chh, cmm, evbs, evcw, sbsno, stm, wetness, & & acsnow, snowfallac, & @@ -282,6 +285,7 @@ subroutine lsm_ruc_run & ! --- inpu integer, intent(in) :: me integer, intent(in) :: im, nlev, iter, lsoil_ruc, lsoil, kdt, isot, ivegsrc integer, intent(in) :: lsm_ruc, lsm + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson real (kind=kind_phys), dimension(im,lsoil), intent(inout) :: smc,stc,slc @@ -305,7 +309,7 @@ subroutine lsm_ruc_run & ! --- inpu real (kind=kind_phys), dimension(lsoil_ruc), intent(inout ) :: zs real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & & snwdph, tskin, & - & srflag, sr, canopy, trans, tsurf, zorl, tsnow, & + & srflag, canopy, trans, tsurf, zorl, tsnow, & & sfcqc, sfcqv, sfcdew, fice, tice, sfalb, smcwlt2, smcref2 ! --- in real (kind=kind_phys), dimension(im), intent(in) :: & @@ -329,7 +333,7 @@ subroutine lsm_ruc_run & ! --- inpu ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & & q0, qs1, wind, weasd_old, snwdph_old, & - & tprcp_old, srflag_old, sr_old, tskin_old, canopy_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old, & & tsnow_old, snowfallac_old, acsnow_old, sfalb_old, & & sfcqv_old, sfcqc_old, wetness_old, zorl_old, sncovr1_old @@ -514,7 +518,6 @@ subroutine lsm_ruc_run & ! --- inpu canopy_old(i) = canopy(i) !tprcp_old(i) = tprcp(i) srflag_old(i) = srflag(i) - sr_old(i) = sr(i) tsnow_old(i) = tsnow(i) snowfallac_old(i) = snowfallac(i) acsnow_old(i) = acsnow(i) @@ -606,22 +609,23 @@ subroutine lsm_ruc_run & ! --- inpu !!\n \a lsoil_ruc - number of soil layers (= 6 or 9) !!\n \a zs - the depth of each soil level (\f$m\f$) - ! DH* TODO - TEST FOR DIFFERENT PHYSICS AND SET ACCORDINGLY? - frpcpn = .true. ! .true. if mixed phase precipitation available (Thompson) + ! Set flag for mixed phase precipitation depending on microphysics scheme. + ! For GFDL and Thompson, srflag is fraction of frozen precip for convective+explicit precip. + if (imp_physics==imp_physics_gfdlmp .or. imp_physics==imp_physics_thompson) then + frpcpn = .true. + else + frpcpn = .false. + endif do j = 1, 1 ! 1:1 do i = 1, im ! i - horizontal loop if (flag_iter(i) .and. flag(i)) then - if(.not.frpcpn) then ! no mixed-phase precipitation available - if (srflag(i) == 1.0) then ! snow phase - ffrozp(i,j) = 1.0 - elseif (srflag(i) == 0.0) then ! rain phase - ffrozp(i,j) = 0.0 - endif - else ! mixed-phase precipitation is available - ffrozp(i,j) = sr(i) - endif ! frpcpn + if (frpcpn) then + ffrozp(i,j) = srflag(i) + else + ffrozp(i,j) = real(nint(srflag(i)),kind_phys) + endif !tgs - for now set rdlai2d to .false., WRF has LAI maps, and RUC LSM ! uses rdlai2d = .true. From f42f84c7fd4a0e3295d4bbe580d9a5e775f5bc6b Mon Sep 17 00:00:00 2001 From: climbfuji Date: Sat, 29 Jun 2019 05:06:11 -0600 Subject: [PATCH 19/19] physics/GFS_debug.F90, physics/sfc_drv_ruc.F90: bugfixes after removing sr from and change to use Sfcprop%wetness for RUC LSM instead of Diag%wet1 for RUC LSM --- physics/GFS_debug.F90 | 7 ++++++- physics/sfc_drv_ruc.F90 | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index c4295871f..c0bfef12b 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -174,7 +174,6 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Sfcprop%f10m' , Sfcprop%f10m) call print_var(mpirank,omprank, blkno, 'Sfcprop%tprcp' , Sfcprop%tprcp) call print_var(mpirank,omprank, blkno, 'Sfcprop%srflag' , Sfcprop%srflag) - call print_var(mpirank,omprank, blkno, 'Sfcprop%sr' , Sfcprop%sr) call print_var(mpirank,omprank, blkno, 'Sfcprop%slc' , Sfcprop%slc) call print_var(mpirank,omprank, blkno, 'Sfcprop%smc' , Sfcprop%smc) call print_var(mpirank,omprank, blkno, 'Sfcprop%stc' , Sfcprop%stc) @@ -321,10 +320,16 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Diag%epi ', Diag%epi) call print_var(mpirank,omprank, blkno, 'Diag%smcwlt2 ', Diag%smcwlt2) call print_var(mpirank,omprank, blkno, 'Diag%smcref2 ', Diag%smcref2) + call print_var(mpirank,omprank, blkno, 'Diag%sr ', Diag%sr) call print_var(mpirank,omprank, blkno, 'Diag%tdomr ', Diag%tdomr) call print_var(mpirank,omprank, blkno, 'Diag%tdomzr ', Diag%tdomzr) call print_var(mpirank,omprank, blkno, 'Diag%tdomip ', Diag%tdomip) call print_var(mpirank,omprank, blkno, 'Diag%tdoms ', Diag%tdoms) + if (Model%lsm == Model%lsm_ruc) then + call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Sfcprop%wetness) + else + call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Diag%wet1) + end if call print_var(mpirank,omprank, blkno, 'Diag%skebu_wts ', Diag%skebu_wts) call print_var(mpirank,omprank, blkno, 'Diag%skebv_wts ', Diag%skebv_wts) call print_var(mpirank,omprank, blkno, 'Diag%sppt_wts ', Diag%sppt_wts) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index e129f5eb1..8316aba4d 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -612,7 +612,7 @@ subroutine lsm_ruc_run & ! inputs ! Set flag for mixed phase precipitation depending on microphysics scheme. ! For GFDL and Thompson, srflag is fraction of frozen precip for convective+explicit precip. - if (imp_physics==imp_physics_gfdlmp .or. imp_physics==imp_physics_thompson) then + if (imp_physics==imp_physics_gfdl .or. imp_physics==imp_physics_thompson) then frpcpn = .true. else frpcpn = .false.