From f94cc61050e504279e29d22d0ef2b248be8e3be7 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 31 Aug 2020 00:32:48 +0000 Subject: [PATCH 001/165] adding print of iaermdl --- physics/GFS_rrtmg_setup.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index b3c91cacc..810a17c0a 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -292,7 +292,8 @@ subroutine GFS_rrtmg_setup_init ( & print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling radinit' print *,' si =',si print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& - & ' iaer=',iaer,' ialb=',ialb,' iems=',iems,' ntcw=',ntcw + & ' iaer=',iaer,' ialb=',ialb,' iems=',iems,' ntcw=',ntcw,& + & ' iaermdl=',iaermdl,' iaerflg=',iaerflg print *,' np3d=',num_p3d,' ntoz=',ntoz,' iovr_sw=',iovr_sw, & & ' iovr_lw=',iovr_lw,' isubc_sw=',isubc_sw, & & ' isubc_lw=',isubc_lw,' icliq_sw=',icliq_sw, & From 736f8f67701733926d7b653121772caf5d797adb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 10 Sep 2020 21:20:10 -0400 Subject: [PATCH 002/165] some surface fixes --- physics/GFS_surface_composites.F90 | 16 +++++++++------- physics/sfc_sice.f | 4 ++-- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index b3000b008..9da662e65 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -478,6 +478,9 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_lnd(i) !tsurf(i) = tsurf_lnd(i) tsfcl(i) = tsfc_lnd(i) ! over land + tsfc(i) = tsfcl(i) + tsfco(i) = tsfc(i) + tisfc(i) = tsfc(i) cmm(i) = cmm_lnd(i) chh(i) = chh_lnd(i) gflx(i) = gflx_lnd(i) @@ -488,11 +491,8 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) - tsfc(i) = tsfc_lnd(i) hice(i) = zero cice(i) = zero - tisfc(i) = tsfc(i) - tsfco(i) = tsfc(i) elseif (islmsk(i) == 0) then zorl(i) = zorl_wat(i) cd(i) = cd_wat(i) @@ -506,7 +506,9 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_wat(i) !tsurf(i) = tsurf_wat(i) tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) + tsfc(i) = tsfco(i) tsfcl(i) = tsfc(i) + tisfc(i) = tsfc(i) cmm(i) = cmm_wat(i) chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) @@ -517,10 +519,8 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) - tsfc(i) = tsfc_wat(i) hice(i) = zero cice(i) = zero - tisfc(i) = tsfc(i) else ! islmsk(i) == 2 zorl(i) = zorl_ice(i) cd(i) = cd_ice(i) @@ -544,9 +544,11 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) + tisfc(i) = tice(i) if (.not. flag_cice(i)) then - tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) +! tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) elseif (wet(i)) then if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) @@ -575,7 +577,7 @@ subroutine GFS_surface_composites_post_run ( endif tsfcl(i) = tsfc(i) do k=1,kice ! store tiice in stc to reduce output in the nonfrac grid case - stc(i,k)=tiice(i,k) + stc(i,k) = tiice(i,k) end do endif diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index ab67f849e..d3f7326f0 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -219,7 +219,7 @@ subroutine sfc_sice_run & endif if (fice(i) > tem) then islmsk_local(i) = 2 - tice(i) =min( tice(i), tgice) + tice(i) = min(tice(i), tgice) endif endif enddo @@ -399,7 +399,6 @@ subroutine sfc_sice_run & print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) endif - tskin(i) = tice(i)*fice(i) + tgice*ffw(i) endif enddo @@ -424,6 +423,7 @@ subroutine sfc_sice_run & #endif hflx(i) = fice(i)*hflxi + ffw(i)*hflxw evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + tskin(i) = fice(i)*tice(i) + ffw(i)*tgice ! ! --- ... the rest of the output From 28cf654806dd1ec6d8ff88386a80a2e683002f3b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 21 Sep 2020 00:25:53 +0000 Subject: [PATCH 003/165] some updates to mg3 --- physics/micro_mg3_0.F90 | 37 +- physics/micro_mg3_0.F90_Sep19 | 4529 +++++++++++++++++++++++++++++++++ 2 files changed, 4553 insertions(+), 13 deletions(-) create mode 100644 physics/micro_mg3_0.F90_Sep19 diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 636293b86..b50980da7 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -1080,7 +1080,7 @@ subroutine micro_mg_tend ( & integer i, k, n ! number of sub-steps for loops over "n" (for sedimentation) - integer nstep, mdust, nlb, nstep_def + integer nstep, mdust, nlb, nstep_def, kmin, kminp1 ! Varaibles to scale fall velocity between small and regular ice regimes. ! real(r8) :: irad, ifrac, tsfac @@ -1092,6 +1092,10 @@ subroutine micro_mg_tend ( & ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) ! ts_au_min=180.0 + real(r8), parameter :: pmin_sed = 5000.0 ! layer pressur in Pa below which + ! sedimentation calcuation is done +! integer, parameter :: nstep_fac=10 ! factor for definng nstep_def + integer, parameter :: nstep_fac=5 ! factor for definng nstep_def !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -1101,8 +1105,7 @@ subroutine micro_mg_tend ( & !> - Assign variable deltat to deltatin deltat = deltatin oneodt = one / deltat -! nstep_def = max(1, nint(deltat/20)) - nstep_def = max(1, nint(deltat/5)) + nstep_def = max(1, nint(deltat/nstep_fac)) ! tsfac = log(ts_au/ts_au_min) * qiinv !> - Copies of input concentrations that may be changed internally. @@ -3412,11 +3415,19 @@ subroutine micro_mg_tend ( & tx1 = tx2 * deltat tx3 = tx2 / g + kmin = 1 + do k=2,nlev-1 + if (p(i,k) < pmin_sed) then + kmin = k + endif + enddo + kminp1 = kmin + 1 + do n = 1,nstep ! top of model - k = 1 + k = kmin ! add fallout terms to microphysical tendencies @@ -3437,7 +3448,7 @@ subroutine micro_mg_tend ( & iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - do k = 2,nlev + do k = kminp1,nlev ! for cloud liquid and ice, if cloud fraction increases with height ! then add flux from above to both vapor and cloud water of current level @@ -3506,7 +3517,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = 1 + k = kmin tx5 = dumc(i,k) tx7 = pdel_inv(i,k) * tx1 @@ -3525,7 +3536,7 @@ subroutine micro_mg_tend ( & faloutnc(k) = fnc(i,k) * dumnc(i,k) lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 - do k = 2,nlev + do k = kminp1,nlev if (lcldm(i,k-1) > mincld) then dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) @@ -3589,7 +3600,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = 1 + k = kmin ! add fallout terms to microphysical tendencies @@ -3610,7 +3621,7 @@ subroutine micro_mg_tend ( & rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 - do k = 2,nlev + do k = kminp1,nlev tx5 = dumr(i,k) tx7 = pdel_inv(i,k) * tx1 @@ -3651,7 +3662,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = 1 + k = kmin ! add fallout terms to microphysical tendencies @@ -3672,7 +3683,7 @@ subroutine micro_mg_tend ( & sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 - do k = 2,nlev + do k = kminp1,nlev tx5 = dums(i,k) @@ -3718,7 +3729,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = 1 + k = kmin ! add fallout terms to microphysical tendencies @@ -3739,7 +3750,7 @@ subroutine micro_mg_tend ( & gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - do k = 2,nlev + do k = kminp1,nlev tx5 = dumg(i,k) tx7 = pdel_inv(i,k) * tx1 diff --git a/physics/micro_mg3_0.F90_Sep19 b/physics/micro_mg3_0.F90_Sep19 new file mode 100644 index 000000000..636293b86 --- /dev/null +++ b/physics/micro_mg3_0.F90_Sep19 @@ -0,0 +1,4529 @@ +!>\file micro_mg3_0.F90 +!! This file contains Morrison-Gettelman MP version 3.0 - +!! Update of MG microphysics with prognostic hail OR graupel. + +!>\ingroup mg2mg3 +!>\defgroup mg3_mp Morrison-Gettelman MP version 3.0 +!> @{ +!!--------------------------------------------------------------------------------- +!! Purpose: +!! MG microphysics version 3.0 - Update of MG microphysics with +!! prognostic hail OR graupel. +!! +!! \authors Andrew Gettelman, Hugh Morrison +!! +!! \version 3 history: Sep 2016: development begun for hail, graupel +!! This version:https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ +!! +!! \version 2 history: Sep 2011: Development begun. +!!\n Feb 2013: Added of prognostic precipitation. +!!\n Aug 2015: Published and released version +!! +!! Contributions from: Sean Santos, Peter Caldwell, Xiaohong Liu and Steve Ghan +!! +!! - Anning Cheng adopted mg2 for FV3GFS 9/29/2017 +!!\n add GMAO ice conversion and Liu et. al liquid water +!!\n conversion in 10/12/2017 +!! +!! - Anning showed promising results for FV3GFS on 10/15/2017 +!! - S. Moorthi - Oct/Nov 2017 - optimized the MG2 code +!! - S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit +!! - S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation +!! other modifications to eliminate blowup. +!! - S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 +!! - S. Moorthi - Oct,29,2018 - change nlb from nlev/3 to levels with p/ps < 0.05 (nlball) +!! +!! invoked in CAM by specifying -microphys=mg3 +!! +!! References: +!! +!! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. +!! Part I: Off line tests and comparisons with other schemes. +!! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. +!! +!! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell +!! Advanced Two-Moment Microphysics for Global Models. +!! 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 +!! controlled by the do_cldice variable. +!! +!! If do_cldice is false, then MG microphysics should not update CLDICE or +!! NUMICE; it is assumed that the other microphysics scheme will have updated +!! CLDICE and NUMICE. The other microphysics should handle the following +!! processes that would have been done by MG: +!! - Detrainment (liquid and ice) +!! - Homogeneous ice nucleation +!! - Heterogeneous ice nucleation +!! - Bergeron process +!! - Melting of ice +!! - Freezing of cloud drops +!! - Autoconversion (ice -> snow) +!! - Growth/Sublimation of ice +!! - Sedimentation of ice +!! +!! This option has not been updated since the introduction of prognostic +!! precipitation, and probably should be adjusted to cover snow as well. +! +!--------------------------------------------------------------------------------- +!Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F +!--------------------------------------------------------------------------------- +! Based on micro_mg (restructuring of former cldwat2m_micro) +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! Code comments added by HM, 093011 +! General code structure: +! +! Code is divided into two main subroutines: +! subroutine micro_mg_init --> initializes microphysics routine, should be called +! once at start of simulation +! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! this also calls several smaller subroutines to calculate +! microphysical processes and other utilities +! +! List of external functions: +! qsat_water --> for calculating saturation vapor pressure with respect to liquid water +! qsat_ice --> for calculating saturation vapor pressure with respect to ice +! gamma --> standard mathematical gamma function +! ......................................................................... +! List of inputs through use statement in fortran90: +! Variable Name Description Units +! ......................................................................... +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! tmelt temperature of melting point for water K +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! qsat_water external function for calculating liquid water +! saturation vapor pressure/humidity - +! qsat_ice external function for calculating ice +! saturation vapor pressure/humidity pa +! rhmini relative humidity threshold parameter for +! nucleating ice - +! ......................................................................... +! NOTE: List of all inputs/outputs passed through the call/subroutine statement +! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure and specific humidity over water +! 3) svp over ice + +module micro_mg3_0 + +use machine, only : r8 => kind_phys +use funcphys, only : fpvsl, fpvsi + +!use wv_sat_methods, only: & +! qsat_water => wv_sat_qsat_water, & +! qsat_ice => wv_sat_qsat_ice + +! Parameters from the utilities module. +use micro_mg_utils, only : pi, omsm, qsmall, mincld, rhosn, rhoi, & + rhow, rhows, ac, bc, ai, bi, & + aj, bj, ar, br, as, bs, & +!++ag + ag, bg, ah, bh, rhog, rhoh, & +!--ag + mi0, rising_factorial + +implicit none +private +save + +public :: micro_mg_init, micro_mg_tend, qcvar + +! Switches for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used +! +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. + +logical :: nccons !< nccons = .true. to specify constant cloud droplet number +logical :: nicons !< nicons = .true. to specify constant cloud ice number +!++ag kt +logical :: ngcons !< ngcons = .true. to specify constant graupel number +!--ag kt + +! specified ice and droplet number concentrations +! note: these are local in-cloud values, not grid-mean +real(r8) :: ncnst !< droplet num concentration when nccons=.true. (m-3) +real(r8) :: ninst !< ice num concentration when nicons=.true. (m-3) +!++ag kt +real(r8) :: ngnst !< graupel num concentration when ngcons=.true. (m-3) +!--ag kt + +!========================================================= +! Private module parameters +!========================================================= + +!> Range of cloudsat reflectivities (dBz) for analytic simulator +real(r8), parameter :: csmin = -30._r8 +real(r8), parameter :: csmax = 26._r8 +real(r8), parameter :: mindbz = -99._r8 +real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) + +! autoconversion size threshold for cloud ice to snow (m) +real(r8) :: dcs, ts_au, ts_au_min, qcvar + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 + +! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. +real(r8), parameter :: sublim_factor = 0.0_r8 !number sublimation factor. + +real(r8), parameter :: zero=0.0_r8, one=1.0_r8, two=2.0_r8, three=3.0_r8, & + four=4.0_r8, five=5.0_r8, six=6._r8, half=0.5_r8, & + ten=10.0_r8, forty=40.0_r8, oneo6=one/six + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: g !< gravity +real(r8) :: r !< dry air gas constant +real(r8) :: rv !< water vapor gas constant +real(r8) :: cpp !< specific heat of dry air +real(r8) :: tmelt !< freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv !< vaporization +real(r8) :: xlf !< freezing +real(r8) :: xxls !< sublimation + +real(r8) :: rhmini !< Minimum rh for ice cloud fraction > 0. + +! flags +logical :: microp_uniform, do_cldice, use_hetfrz_classnuc, & +!++ag + do_hail, do_graupel +!--ag + +real(r8) :: rhosu !< typical 850mn air density + +real(r8) :: icenuct !< ice nucleation temperature: currently -5 degrees C + +real(r8) :: snowmelt !< what temp to melt all snow: currently 2 degrees C +real(r8) :: rainfrze !< what temp to freeze all rain: currently -5 degrees C + +real(r8) :: rhogtmp !< hail or graupel density (kg m-3) +real(r8) :: agtmp !< tmp ag/ah parameter +real(r8) :: bgtmp !< tmp fall speed parameter + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1, gamma_bg_plus1 +real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4, gamma_bg_plus4 +real(r8) :: xxlv_squared, xxls_squared +real(r8) :: omeps, epsqs + +character(len=16) :: micro_mg_precip_frac_method !< type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor !< berg efficiency factor + +logical :: allow_sed_supersat !< Allow supersaturated conditions after sedimentation loop +logical :: do_sb_physics !< do SB 2001 autoconversion or accretion physics +logical :: do_ice_gmao +logical :: do_liq_liu + +!=============================================================================== +contains +!=============================================================================== + +!>\ingroup mg3_mp +!! This subroutine initializes the microphysics +!! and needs to be called once at start of simulation. +!!\author Andrew Gettelman, Dec 2005 +subroutine micro_mg_init( & + kind, gravit, rair, rh2o, cpair, eps, & + tmelt_in, latvap, latice, & + rhmini_in, micro_mg_dcs,ts_auto, mg_qcvar, & +!++ag + micro_mg_do_hail_in, micro_mg_do_graupel_in, & +!--ag + microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & + allow_sed_supersat_in, do_sb_physics_in, & + do_ice_gmao_in, do_liq_liu_in, & + nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in) +! nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, errstring) + + use micro_mg_utils, only : micro_mg_utils_init + use wv_saturation, only : gestbl + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize constants for MG microphysics + ! + ! Author: Andrew Gettelman Dec 2005 + ! + !----------------------------------------------------------------------- + + 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) :: eps +! real(r8), intent(in) :: fv + 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) :: 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) +!--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 + + 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 + + logical, intent(in) :: nccons_in, nicons_in, ngcons_in + real(r8), intent(in) :: ncnst_in, ninst_in, ngnst_in + logical ip + real(r8):: tmn, tmx, trice + + +! character(128), intent(out) :: errstring ! Output status (non-blank for error return) + + !----------------------------------------------------------------------- + + dcs = micro_mg_dcs * 1.0e-6_r8 + ts_au_min = ts_auto(1) + ts_au = ts_auto(2) + qcvar = mg_qcvar + + ! Initialize subordinate utilities module. + call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & + dcs) +! dcs, errstring) + +! if (trim(errstring) /= "") return + + ! declarations for MG code (transforms variable names) + + g = gravit ! gravity + r = rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) +! write(0,*)' in micro_mg_utils_init=',' r=',r,' rair=',rair,' rh2o=',rh2o + rv = rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + rhmini = rhmini_in + micro_mg_precip_frac_method = micro_mg_precip_frac_method_in + micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + allow_sed_supersat = allow_sed_supersat_in + do_sb_physics = do_sb_physics_in + do_ice_gmao = do_ice_gmao_in + do_liq_liu = do_liq_liu_in + + nccons = nccons_in + nicons = nicons_in + ncnst = ncnst_in + ninst = ninst_in +!++ag + ngcons = ngcons_in + ngnst = ngnst_in +!--ag + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! flags + microp_uniform = microp_uniform_in + do_cldice = do_cldice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in +!++ag + do_hail = micro_mg_do_hail_in + do_graupel = micro_mg_do_graupel_in +! + if (do_hail) then + agtmp = ah + bgtmp = bh + rhogtmp = rhoh + elseif (do_graupel) then + agtmp = ag + bgtmp = bg + rhogtmp = rhog + else + agtmp = zero + bgtmp = zero + endif +!--ag + + ! typical air density at 850 mb + + rhosu = 85000._r8 / (rair * tmelt) + + ! Maximum temperature at which snow is allowed to exist + snowmelt = tmelt + two + ! Minimum temperature at which rain is allowed to exist + rainfrze = tmelt - forty + + ! Ice nucleation temperature + icenuct = tmelt - five + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_br_plus1 = gamma(br+one) + gamma_br_plus4 = gamma(br+four) + gamma_bs_plus1 = gamma(bs+one) + gamma_bs_plus4 = gamma(bs+four) + gamma_bi_plus1 = gamma(bi+one) + gamma_bi_plus4 = gamma(bi+four) + gamma_bj_plus1 = gamma(bj+one) + gamma_bj_plus4 = gamma(bj+four) +! + gamma_bg_plus1 = gamma(bgtmp+one) + gamma_bg_plus4 = gamma(bgtmp+four) + + xxlv_squared = xxlv * xxlv + xxls_squared = xxls * xxls + epsqs = eps + omeps = one - epsqs + tmn = 173.16_r8 + tmx = 375.16_r8 + trice = 35.00_r8 + ip = .true. +!> - call gestbl() + call gestbl(tmn ,tmx ,trice ,ip ,epsqs , latvap ,latice ,rh2o , & + cpair ,tmelt_in ) + + + +end subroutine micro_mg_init + +!=============================================================================== +!microphysics routine for each timestep goes here... + +!>\ingroup mg3_mp +!! This subroutine calculates the MG3 microphysical processes. +!>\authors Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL +!! e-mail: morrison@ucar.edu, andrew@ucar.edu +!!\section mg3_micro_mg_tend MG3 micro_mg_tend General Algorithm +!> @{ +subroutine micro_mg_tend ( & + mgncol, nlev, deltatin, & + t, q, & + qcn, qin, & + ncn, nin, & + qrn, qsn, & + nrn, nsn, & +!++ag + qgr, ngr, & +!--ag + relvar, accre_enhan_i, & + p, pdel, & + cldn, liqcldf, icecldf, qsatfac, & + qcsinksum_rate1ord, & + naai, npccnin, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & +!++ag + qgtend, ngtend, & +!--ag + effc, effc_fn, effi, & + sadice, sadsnow, & + prect, preci, & + nevapr, evapsnow, & + am_evp_st, & + prain, prodsnow, & + cmeout, deffi, & + pgamrad, lamcrad, & + qsout, dsout, & +!++ag + qgout, ngout, dgout, & +!--ag + lflx, iflx, & +!++ag + gflx, & +!--ag + rflx, sflx, qrout, & +!++ag + reff_rain, reff_snow, reff_grau, & +!--ag + + qcsevap, qisevap, qvres, & + cmeitot, vtrmc, vtrmi, & + umr, ums, & +!++ag + umg, qgsedten, & +!--ag + qcsedten, qisedten, & + qrsedten, qssedten, & + pratot, prctot, & + mnuccctot, mnuccttot, msacwitot, & + psacwstot, bergstot, bergtot, & + melttot, homotot, & + qcrestot, prcitot, praitot, & +!++ag + qirestot, mnuccrtot, mnuccritot, pracstot, & +!--ag + meltsdttot, frzrdttot, mnuccdtot, & +!++ag + pracgtot, psacwgtot, pgsacwtot, & + pgracstot, prdgtot, & + qmultgtot, qmultrgtot, psacrtot, & + npracgtot, nscngtot, ngracstot, & + nmultgtot, nmultrgtot, npsacwgtot, & +!--ag + nrout, nsout, & + refl, arefl, areflz, & + frefl, csrfl, acsrfl, & + fcsrfl, rercld, & + ncai, ncal, & + qrout2, qsout2, & + nrout2, nsout2, & + drout2, dsout2, & +!++ag + qgout2, ngout2, dgout2, freqg, & +!--ag + freqs, freqr, & + nfice, qcrat, & + prer_evap, xlat, xlon, lprnt, iccn, nlball) + + ! Constituent properties. + use micro_mg_utils, only: mg_liq_props, & + mg_ice_props, & + mg_rain_props, & +!++ag + mg_graupel_props,& +!--ag + mg_snow_props + + ! Size calculation functions. + use micro_mg_utils, only: size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter + + ! Microphysical processes. + use micro_mg_utils, only: ice_deposition_sublimation, & + sb2001v2_liq_autoconversion, & + sb2001v2_accre_cld_water_rain, & + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + snow_self_aggregation, & + accrete_cloud_water_snow, & + secondary_ice_production, & + accrete_rain_snow, & + heterogeneous_rain_freezing, & + accrete_cloud_water_rain, & + self_collection_rain, & + accrete_cloud_ice_snow, & + evaporate_sublimate_precip, & + bergeron_process_snow, & + size_dist_param_ice, & +!++ag + graupel_collecting_snow, & + graupel_collecting_rain, & + graupel_collecting_cld_water, & + graupel_riming_liquid_snow, & + graupel_rain_riming_snow, & + graupel_rime_splintering, & + evaporate_sublimate_precip_graupel,& +! graupel_sublimate_evap +!--ag + liu_liq_autoconversion, & + gmao_ice_autoconversion + + !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL + ! e-mail: morrison@ucar.edu, andrew@ucar.edu + + ! input arguments + integer, intent(in) :: mgncol !< number of microphysics columns + integer, intent(in) :: nlev !< number of layers + integer, intent(in) :: nlball(mgncol) !< sedimentation start level + real(r8), intent(in) :: xlat,xlon !< number of layers + real(r8), intent(in) :: deltatin !< time step (s) + real(r8), intent(in) :: t(mgncol,nlev) !< input temperature (K) + real(r8), intent(in) :: q(mgncol,nlev) !< input h20 vapor mixing ratio (kg/kg) + + ! note: all input cloud variables are grid-averaged + real(r8), intent(in) :: qcn(mgncol,nlev) !< cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(mgncol,nlev) !< cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: ncn(mgncol,nlev) !< cloud water number conc (1/kg) + real(r8), intent(in) :: nin(mgncol,nlev) !< cloud ice number conc (1/kg) + + real(r8), intent(in) :: qrn(mgncol,nlev) !< rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(mgncol,nlev) !< snow mixing ratio (kg/kg) + real(r8), intent(in) :: nrn(mgncol,nlev) !< rain number conc (1/kg) + real(r8), intent(in) :: nsn(mgncol,nlev) !< snow number conc (1/kg) +!++ag + real(r8), intent(in) :: qgr(mgncol,nlev) !< graupel/hail mixing ratio (kg/kg) + real(r8), intent(in) :: ngr(mgncol,nlev) !< graupel/hail number conc (1/kg) +!--ag + + real(r8) :: relvar(mgncol,nlev) !< cloud water relative variance (-) + real(r8) :: accre_enhan(mgncol,nlev)!< optional accretion +! real(r8), intent(in) :: relvar_i !< cloud water relative variance (-) + real(r8), intent(in) :: accre_enhan_i !< optional accretion + !< enhancement factor (-) + + real(r8), intent(in) :: p(mgncol,nlev) !< air pressure (pa) + real(r8), intent(in) :: pdel(mgncol,nlev) !< pressure difference across level (pa) + + real(r8), intent(in) :: cldn(mgncol,nlev) !< cloud fraction (no units) + 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 !< control flag for diagnostic print out + integer, intent(in) :: iccn !< flag for IN and CCN forcing for Morrison-Gettelman microphysics + + + ! used for scavenging + ! Inputs for aerosol activation + real(r8), intent(inout) :: naai(mgncol,nlev) !< ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccnin(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) +! real(r8), intent(in) :: npccn(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) + real(r8) :: npccn(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) + + ! Note that for these variables, the dust bin is assumed to be the last index. + ! (For example, in CAM, the last dimension is always size 4.) + real(r8), intent(in) :: rndst(mgncol,nlev,10) !< radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(mgncol,nlev,10) !< number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) + + ! output arguments + + real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) !< 1st order rate for + !! direct cw to precip conversion + real(r8), intent(out) :: tlat(mgncol,nlev) !< latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(mgncol,nlev) !< microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(mgncol,nlev) !< microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(mgncol,nlev) !< microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(mgncol,nlev) !< microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(mgncol,nlev) !< microphysical tendency ni (1/(kg*s)) + + real(r8), intent(out) :: qrtend(mgncol,nlev) !< microphysical tendency qr (1/s) + real(r8), intent(out) :: qstend(mgncol,nlev) !< microphysical tendency qs (1/s) + real(r8), intent(out) :: nrtend(mgncol,nlev) !< microphysical tendency nr (1/(kg*s)) + real(r8), intent(out) :: nstend(mgncol,nlev) !< microphysical tendency ns (1/(kg*s)) +!++ag + real(r8), intent(out) :: qgtend(mgncol,nlev) !< microphysical tendency qg (1/s) + real(r8), intent(out) :: ngtend(mgncol,nlev) !< microphysical tendency ng (1/(kg*s)) +!--ag + real(r8), intent(out) :: effc(mgncol,nlev) !< droplet effective radius (micron) + real(r8), intent(out) :: effc_fn(mgncol,nlev) !< droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8), intent(out) :: effi(mgncol,nlev) !< cloud ice effective radius (micron) + real(r8), intent(out) :: sadice(mgncol,nlev) !< cloud ice surface area density (cm2/cm3) + real(r8), intent(out) :: sadsnow(mgncol,nlev) !< cloud snow surface area density (cm2/cm3) + real(r8), intent(out) :: prect(mgncol) !< surface precip rate (m/s) + real(r8), intent(out) :: preci(mgncol) !< cloud ice/snow precip rate (m/s) + real(r8), intent(out) :: nevapr(mgncol,nlev) !< evaporation rate of rain + snow (1/s) + real(r8), intent(out) :: evapsnow(mgncol,nlev) !< sublimation rate of snow (1/s) + real(r8), intent(out) :: am_evp_st(mgncol,nlev) !< stratiform evaporation area (frac) + real(r8), intent(out) :: prain(mgncol,nlev) !< production of rain + snow (1/s) + real(r8), intent(out) :: prodsnow(mgncol,nlev) !< production of snow (1/s) + real(r8), intent(out) :: cmeout(mgncol,nlev) !< evap/sub of cloud (1/s) + real(r8), intent(out) :: deffi(mgncol,nlev) !< ice effective diameter for optics (radiation) (micron) + real(r8), intent(out) :: pgamrad(mgncol,nlev) !< ice gamma parameter for optics (radiation) (no units) + real(r8), intent(out) :: lamcrad(mgncol,nlev) !< slope of droplet distribution for optics (radiation) (1/m) + real(r8), intent(out) :: qsout(mgncol,nlev) !< snow mixing ratio (kg/kg) + real(r8), intent(out) :: dsout(mgncol,nlev) !< snow diameter (m) + real(r8), intent(out) :: lflx(mgncol,2:nlev+1) !< grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: iflx(mgncol,2:nlev+1) !< grid-box average ice condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: rflx(mgncol,2:nlev+1) !< grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,2:nlev+1) !< grid-box average snow flux (kg m^-2 s^-1) +!++ag + real(r8), intent(out) :: gflx(mgncol,2:nlev+1) !< grid-box average graupel/hail flux (kg m^-2 s^-1) +!--ag + real(r8), intent(out) :: qrout(mgncol,nlev) !< grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(mgncol,nlev) !< rain effective radius (micron) + real(r8), intent(out) :: reff_snow(mgncol,nlev) !< snow effective radius (micron) +!++ag + real(r8), intent(out) :: reff_grau(mgncol,nlev) !< graupel effective radius (micron) +!--ag + real(r8), intent(out) :: qcsevap(mgncol,nlev) !< cloud water evaporation due to sedimentation (1/s) + real(r8), intent(out) :: qisevap(mgncol,nlev) !< cloud ice sublimation due to sedimentation (1/s) + real(r8), intent(out) :: qvres(mgncol,nlev) !< residual condensation term to ensure RH < 100% (1/s) + real(r8), intent(out) :: cmeitot(mgncol,nlev) !< grid-mean cloud ice sub/dep (1/s) + real(r8), intent(out) :: vtrmc(mgncol,nlev) !< mass-weighted cloud water fallspeed (m/s) + real(r8), intent(out) :: vtrmi(mgncol,nlev) !< mass-weighted cloud ice fallspeed (m/s) + real(r8), intent(out) :: umr(mgncol,nlev) !< mass weighted rain fallspeed (m/s) + real(r8), intent(out) :: ums(mgncol,nlev) !< mass weighted snow fallspeed (m/s) +!++ag + real(r8), intent(out) :: umg(mgncol,nlev) !< mass weighted graupel/hail fallspeed (m/s) + real(r8), intent(out) :: qgsedten(mgncol,nlev) !< qg sedimentation tendency (1/s) +!--ag + + real(r8), intent(out) :: qcsedten(mgncol,nlev) !< qc sedimentation tendency (1/s) + real(r8), intent(out) :: qisedten(mgncol,nlev) !< qi sedimentation tendency (1/s) + real(r8), intent(out) :: qrsedten(mgncol,nlev) !< qr sedimentation tendency (1/s) + real(r8), intent(out) :: qssedten(mgncol,nlev) !< qs sedimentation tendency (1/s) + + ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) + real(r8), intent(out) :: pratot(mgncol,nlev) !< accretion of cloud by rain + real(r8), intent(out) :: prctot(mgncol,nlev) !< autoconversion of cloud to rain + real(r8), intent(out) :: mnuccctot(mgncol,nlev) !< mixing ratio tend due to immersion freezing + real(r8), intent(out) :: mnuccttot(mgncol,nlev) !< mixing ratio tend due to contact freezing + real(r8), intent(out) :: msacwitot(mgncol,nlev) !< mixing ratio tend due to H-M splintering + real(r8), intent(out) :: psacwstot(mgncol,nlev) !< collection of cloud water by snow + real(r8), intent(out) :: bergstot(mgncol,nlev) !< bergeron process on snow + real(r8), intent(out) :: bergtot(mgncol,nlev) !< bergeron process on cloud ice + real(r8), intent(out) :: melttot(mgncol,nlev) !< melting of cloud ice + real(r8), intent(out) :: homotot(mgncol,nlev) !< homogeneous freezing cloud water + real(r8), intent(out) :: qcrestot(mgncol,nlev) !< residual cloud condensation due to removal of excess supersat + real(r8), intent(out) :: prcitot(mgncol,nlev) !< autoconversion of cloud ice to snow + real(r8), intent(out) :: praitot(mgncol,nlev) !< accretion of cloud ice by snow + real(r8), intent(out) :: qirestot(mgncol,nlev) !< residual ice deposition due to removal of excess supersat + real(r8), intent(out) :: mnuccrtot(mgncol,nlev) !< mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: mnuccritot(mgncol,nlev)!< mixing ratio tendency due to heterogeneous freezing of rain to ice (1/s) + real(r8), intent(out) :: pracstot(mgncol,nlev) !< mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8), intent(out) :: meltsdttot(mgncol,nlev)!< latent heating rate due to melting of snow (W/kg) + real(r8), intent(out) :: frzrdttot(mgncol,nlev) !< latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8), intent(out) :: mnuccdtot(mgncol,nlev) !< mass tendency from ice nucleation +!++ag Hail/Graupel Tendencies + real(r8), intent(out) :: pracgtot(mgncol,nlev) !< change in q collection rain by graupel (precipf) + real(r8), intent(out) :: psacwgtot(mgncol,nlev) !< change in q collection droplets by graupel (lcldm) + real(r8), intent(out) :: pgsacwtot(mgncol,nlev) !< conversion q to graupel due to collection droplets by snow (lcldm) + real(r8), intent(out) :: pgracstot(mgncol,nlev) !< conversion q to graupel due to collection rain by snow (precipf) + real(r8), intent(out) :: prdgtot(mgncol,nlev) !< dep of graupel (precipf) +! real(r8), intent(out) :: eprdgtot(mgncol,nlev) !< sub of graupel (precipf) + real(r8), intent(out) :: qmultgtot(mgncol,nlev) !< change q due to ice mult droplets/graupel (lcldm) + real(r8), intent(out) :: qmultrgtot(mgncol,nlev)!< change q due to ice mult rain/graupel (precipf) + real(r8), intent(out) :: psacrtot(mgncol,nlev) !< conversion due to coll of snow by rain (precipf) + real(r8), intent(out) :: npracgtot(mgncol,nlev) !< change n collection rain by graupel (precipf) + real(r8), intent(out) :: nscngtot(mgncol,nlev) !< change n conversion to graupel due to collection droplets by snow (lcldm) + real(r8), intent(out) :: ngracstot(mgncol,nlev) !< change n conversion to graupel due to collection rain by snow (precipf) + real(r8), intent(out) :: nmultgtot(mgncol,nlev) !< ice mult due to acc droplets by graupel (lcldm) + real(r8), intent(out) :: nmultrgtot(mgncol,nlev)!< ice mult due to acc rain by graupel (precipf) + real(r8), intent(out) :: npsacwgtot(mgncol,nlev)!< change n collection droplets by graupel (lcldm?) +!--ag + real(r8), intent(out) :: nrout(mgncol,nlev) !< rain number concentration (1/m3) + real(r8), intent(out) :: nsout(mgncol,nlev) !< snow number concentration (1/m3) + real(r8), intent(out) :: refl(mgncol,nlev) !< analytic radar reflectivity + real(r8), intent(out) :: arefl(mgncol,nlev) !< average reflectivity will zero points outside valid range + real(r8), intent(out) :: areflz(mgncol,nlev) !< average reflectivity in z. + real(r8), intent(out) :: frefl(mgncol,nlev) !< fractional occurrence of radar reflectivity + real(r8), intent(out) :: csrfl(mgncol,nlev) !< cloudsat reflectivity + real(r8), intent(out) :: acsrfl(mgncol,nlev) !< cloudsat average + real(r8), intent(out) :: fcsrfl(mgncol,nlev) !< cloudsat fractional occurrence of radar reflectivity + real(r8), intent(out) :: rercld(mgncol,nlev) !< effective radius calculation for rain + cloud + real(r8), intent(out) :: ncai(mgncol,nlev) !< output number conc of ice nuclei available (1/m3) + real(r8), intent(out) :: ncal(mgncol,nlev) !< output number conc of CCN (1/m3) + real(r8), intent(out) :: qrout2(mgncol,nlev) !< copy of qrout as used to compute drout2 + real(r8), intent(out) :: qsout2(mgncol,nlev) !< copy of qsout as used to compute dsout2 + real(r8), intent(out) :: nrout2(mgncol,nlev) !< copy of nrout as used to compute drout2 + real(r8), intent(out) :: nsout2(mgncol,nlev) !< copy of nsout as used to compute dsout2 + real(r8), intent(out) :: drout2(mgncol,nlev) !< mean rain particle diameter (m) + real(r8), intent(out) :: dsout2(mgncol,nlev) !< mean snow particle diameter (m) + real(r8), intent(out) :: freqs(mgncol,nlev) !< fractional occurrence of snow + real(r8), intent(out) :: freqr(mgncol,nlev) !< fractional occurrence of rain + real(r8), intent(out) :: nfice(mgncol,nlev) !< fractional occurrence of ice + real(r8), intent(out) :: qcrat(mgncol,nlev) !< limiter for qc process rates (1=no limit --> 0. no qc) +!++ag + real(r8), intent(out) :: qgout(mgncol,nlev) !< graupel/hail mixing ratio (kg/kg) + real(r8), intent(out) :: dgout(mgncol,nlev) !< graupel/hail diameter (m) + real(r8), intent(out) :: ngout(mgncol,nlev) !< graupel/hail number concentration (1/m3) +!Not sure if these are needed since graupel/hail is prognostic? + real(r8), intent(out) :: qgout2(mgncol,nlev) !< copy of qgout as used to compute dgout2 + real(r8), intent(out) :: ngout2(mgncol,nlev) !< copy of ngout as used to compute dgout2 + real(r8), intent(out) :: dgout2(mgncol,nlev) !< mean graupel/hail particle diameter (m) + real(r8), intent(out) :: freqg(mgncol,nlev) !< fractional occurrence of graupel + +!--ag + + real(r8), intent(out) :: prer_evap(mgncol,nlev) + + + ! Tendencies calculated by external schemes that can replace MG's native + ! process tendencies. + + ! Used with CARMA cirrus microphysics + ! (or similar external microphysics model) + ! real(r8), intent(in) :: tnd_qsnow(:,:) !< snow mass tendency (kg/kg/s) + ! real(r8), intent(in) :: tnd_nsnow(:,:) !< snow number tendency (#/kg/s) + ! real(r8), intent(in) :: re_ice(:,:) !< ice effective radius (m) + + ! From external ice nucleation. + !real(r8), intent(in) :: frzimm(:,:) !< Number tendency due to immersion freezing (1/cm3) + !real(r8), intent(in) :: frzcnt(:,:) !< Number tendency due to contact freezing (1/cm3) + !real(r8), intent(in) :: frzdep(:,:) !< Number tendency due to deposition nucleation (1/cm3) + + ! local workspace + ! all units mks unless otherwise stated + + ! local copies of input variables + real(r8) :: qc(mgncol,nlev) !< cloud liquid mixing ratio (kg/kg) + real(r8) :: qi(mgncol,nlev) !< cloud ice mixing ratio (kg/kg) + real(r8) :: nc(mgncol,nlev) !< cloud liquid number concentration (1/kg) + real(r8) :: ni(mgncol,nlev) !< cloud liquid number concentration (1/kg) + real(r8) :: qr(mgncol,nlev) !< rain mixing ratio (kg/kg) + real(r8) :: qs(mgncol,nlev) !< snow mixing ratio (kg/kg) + real(r8) :: nr(mgncol,nlev) !< rain number concentration (1/kg) + real(r8) :: ns(mgncol,nlev) !< snow number concentration (1/kg) +!++ag + real(r8) :: qg(mgncol,nlev) !< graupel mixing ratio (kg/kg) + real(r8) :: ng(mgncol,nlev) !< graupel number concentration (1/kg) +! real(r8) :: rhogtmp !< hail or graupel density (kg m-3) + +!--ag + + ! general purpose variables + real(r8) :: deltat !< sub-time step (s) + real(r8) :: oneodt !< one / deltat + real(r8) :: mtime !< the assumed ice nucleation timescale + + ! physical properties of the air at a given point + real(r8) :: rho(mgncol,nlev) ! density (kg m-3) + real(r8) :: rhoinv(mgncol,nlev) ! one / density (kg m-3) + real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor + real(r8) :: mu(mgncol,nlev) ! viscosity + real(r8) :: sc(mgncol,nlev) ! schmidt number + real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed + + ! cloud fractions + real(r8) :: precip_frac(mgncol,nlev)! precip fraction assuming maximum overlap + real(r8) :: cldm(mgncol,nlev) ! cloud fraction + real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction + real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction + real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor + + ! mass mixing ratios + real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid + real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: qsic(mgncol,nlev) ! in-precip snow + real(r8) :: qric(mgncol,nlev) ! in-precip rain +!++ag + real(r8) :: qgic(mgncol,nlev) ! in-precip graupel/hail +!++ag + + + ! number concentrations + real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet + real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: nsic(mgncol,nlev) ! in-precip snow + real(r8) :: nric(mgncol,nlev) ! in-precip rain +!++ag + real(r8) :: ngic(mgncol,nlev) ! in-precip graupel/hail +!++ag + + ! maximum allowed ni value + real(r8) :: nimax(mgncol,nlev) + + ! Size distribution parameters for: + ! cloud ice + real(r8) :: lami(mgncol,nlev) ! slope + real(r8) :: n0i(mgncol,nlev) ! intercept + ! cloud liquid + real(r8) :: lamc(mgncol,nlev) ! slope + real(r8) :: pgam(mgncol,nlev) ! spectral width parameter + ! snow + real(r8) :: lams(mgncol,nlev) ! slope + real(r8) :: n0s(mgncol,nlev) ! intercept + ! rain + real(r8) :: lamr(mgncol,nlev) ! slope + real(r8) :: n0r(mgncol,nlev) ! intercept +!++ag + ! graupel/hail + real(r8) :: lamg(mgncol,nlev) ! slope + real(r8) :: n0g(mgncol,nlev) ! intercept +! real(r8) :: bgtmp ! tmp fall speed parameter +!--ag + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration +!++ag + ! Instantaneous graupel melting + real(r8) :: minstgm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstgm(mgncol,nlev) ! number concentration +!--ag + + ! Instantaneous rain freezing + real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstrf(mgncol,nlev) ! number concentration + + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 + ! ice nucleation + real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing + real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio + ! freezing of cloud water + real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccc(mgncol,nlev) ! number concentration + ! contact freezing of cloud water + real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration + ! ice multiplication + real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio + real(r8) :: nsacwi(mgncol,nlev) ! number concentration + ! autoconversion of cloud droplets + real(r8) :: prc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) + real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) + ! self-aggregation of snow + real(r8) :: nsagg(mgncol,nlev) ! number concentration + ! self-collection of rain + real(r8) :: nragg(mgncol,nlev) ! number concentration + ! collection of droplets by snow + real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio + real(r8) :: npsacws(mgncol,nlev) ! number concentration + ! collection of rain by snow + real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio + real(r8) :: npracs(mgncol,nlev) ! number concentration + ! freezing of rain + real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccr(mgncol,nlev) ! number concentration + ! freezing of rain to form ice (mg add 4/26/13) + real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccri(mgncol,nlev) ! number concentration + ! accretion of droplets by rain + real(r8) :: pra(mgncol,nlev) ! mass mixing ratio + real(r8) :: npra(mgncol,nlev) ! number concentration + ! autoconversion of cloud ice to snow + real(r8) :: prci(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprci(mgncol,nlev) ! number concentration + ! accretion of cloud ice by snow + real(r8) :: prai(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprai(mgncol,nlev) ! number concentration + ! evaporation of rain + real(r8) :: pre(mgncol,nlev) ! mass mixing ratio + ! sublimation of snow + real(r8) :: prds(mgncol,nlev) ! mass mixing ratio + ! number evaporation + real(r8) :: nsubi(mgncol,nlev) ! cloud ice + real(r8) :: nsubc(mgncol,nlev) ! droplet + real(r8) :: nsubs(mgncol,nlev) ! snow + real(r8) :: nsubr(mgncol,nlev) ! rain + ! bergeron process + real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) + real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) + +!++ag + !graupel/hail processes + real(r8) :: npracg(mgncol,nlev) ! change n collection rain by graupel (precipf) + real(r8) :: nscng(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) + real(r8) :: ngracs(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) + real(r8) :: nmultg(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) + real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel (precipf) + real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm) + + real(r8) :: psacr(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) + real(r8) :: pracg(mgncol,nlev) ! change in q collection rain by graupel (precipf) + real(r8) :: psacwg(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) + real(r8) :: pgsacw(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) + real(r8) :: pgracs(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) + real(r8) :: prdg(mgncol,nlev) ! dep of graupel (precipf) +! real(r8) :: eprdg(mgncol,nlev) ! evap/sub of graupel (precipf) + real(r8) :: qmultg(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) + real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf) +!--ag + + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain +!++ag + real(r8) :: ung(mgncol,nlev) ! graupel/hail +!--ag + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow +!++a + real(r8) :: agn(mgncol,nlev) ! graupel +!--ag + real(r8) :: acn(mgncol,nlev) ! cloud droplet + real(r8) :: ain(mgncol,nlev) ! cloud ice + real(r8) :: ajn(mgncol,nlev) ! cloud small ice + + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + + ! saturation vapor pressures + real(r8) :: esl(mgncol,nlev) ! liquid + real(r8) :: esi(mgncol,nlev) ! ice + real(r8) :: esn ! checking for RH after rain evap + + ! saturation vapor mixing ratios + real(r8) :: qvl(mgncol,nlev) ! liquid + real(r8) :: qvi(mgncol,nlev) ! ice + real(r8) :: qvn ! checking for RH after rain evap + + ! relative humidity + real(r8) :: relhum(mgncol,nlev) + + ! parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fc(mgncol,nlev) + real(r8) :: fnc(mgncol,nlev) + real(r8) :: fi(mgncol,nlev) + real(r8) :: fni(mgncol,nlev) + +!++ag + real(r8) :: fg(mgncol,nlev) + real(r8) :: fng(mgncol,nlev) +!--ag + + real(r8) :: fr(mgncol,nlev) + real(r8) :: fnr(mgncol,nlev) + real(r8) :: fs(mgncol,nlev) + real(r8) :: fns(mgncol,nlev) + + real(r8) :: faloutc(nlev) + real(r8) :: faloutnc(nlev) + real(r8) :: falouti(nlev) + real(r8) :: faloutni(nlev) + + real(r8) :: faloutr(nlev) + real(r8) :: faloutnr(nlev) + real(r8) :: falouts(nlev) + real(r8) :: faloutns(nlev) + + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltndqie + real(r8) :: faltndqce + + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltnds + real(r8) :: faltndns + +!++ag + real(r8) :: faloutg(nlev) + real(r8) :: faloutng(nlev) + real(r8) :: faltndg + real(r8) :: faltndng +!--ag + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 +!++ag + real(r8) :: dum3 +!--ag + real(r8) :: dumni0 + real(r8) :: dumns0 + real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho + ! dummies for checking RH + real(r8) :: qtmp + real(r8) :: ttmp + ! dummies for conservation check + real(r8) :: ratio + real(r8) :: tmpfrz + ! dummies for in-cloud variables + real(r8) :: dumc(mgncol,nlev) ! qc + real(r8) :: dumnc(mgncol,nlev) ! nc + real(r8) :: dumi(mgncol,nlev) ! qi + real(r8) :: dumni(mgncol,nlev) ! ni + real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio + real(r8) :: dumnr(mgncol,nlev) ! rain number concentration + real(r8) :: dums(mgncol,nlev) ! snow mixing ratio + real(r8) :: dumns(mgncol,nlev) ! snow number concentration +!++ag + real(r8) :: dumg(mgncol,nlev) ! graupel mixing ratio + real(r8) :: dumng(mgncol,nlev) ! graupel number concentration +!--ag + ! Array dummy variable +! real(r8) :: dum_2D(mgncol,nlev) + real(r8) :: pdel_inv(mgncol,nlev) + real(r8) :: ts_au_loc(mgncol) + + ! loop array variables + ! "i" and "k" are column/level iterators for internal (MG) variables + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n + + ! number of sub-steps for loops over "n" (for sedimentation) + integer nstep, mdust, nlb, nstep_def + + ! Varaibles to scale fall velocity between small and regular ice regimes. +! real(r8) :: irad, ifrac, tsfac + real(r8) :: irad, ifrac +! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.true. +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. +! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & +! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & + real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) +! ts_au_min=180.0 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + ! Process inputs + + !> - Assign variable deltat to deltatin + deltat = deltatin + oneodt = one / deltat +! nstep_def = max(1, nint(deltat/20)) + nstep_def = max(1, nint(deltat/5)) +! tsfac = log(ts_au/ts_au_min) * qiinv + + !> - Copies of input concentrations that may be changed internally. + do k=1,nlev + do i=1,mgncol + qc(i,k) = qcn(i,k) + nc(i,k) = ncn(i,k) + qi(i,k) = qin(i,k) + ni(i,k) = nin(i,k) + qr(i,k) = qrn(i,k) + nr(i,k) = nrn(i,k) + qs(i,k) = qsn(i,k) + ns(i,k) = nsn(i,k) +!++ag + qg(i,k) = qgr(i,k) + ng(i,k) = ngr(i,k) + enddo + enddo + + ! cldn: used to set cldm, unused for subcolumns + ! liqcldf: used to set lcldm, unused for subcolumns + ! icecldf: used to set icldm, unused for subcolumns +!> - Calculation liquid/ice cloud fraction + if (microp_uniform) then + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors). + + do k=1,nlev + do i=1,mgncol + + if (qc(i,k) >= qsmall) then + lcldm(i,k) = one + else + lcldm(i,k) = mincld + endif + + if (qi(i,k) >= qsmall) then + icldm(i,k) = one + else + icldm(i,k) = mincld + endif + + cldm(i,k) = max(icldm(i,k), lcldm(i,k)) +! qsfm(i,k) = one + qsfm(i,k) = qsatfac(i,k) + enddo + enddo + + else ! get cloud fraction, check for minimum + do k=1,nlev + do i=1,mgncol + cldm(i,k) = max(cldn(i,k), mincld) + lcldm(i,k) = max(liqcldf(i,k), mincld) + icldm(i,k) = max(icecldf(i,k), mincld) + qsfm(i,k) = qsatfac(i,k) + enddo + enddo + end if + +! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) +! if (lprnt) write(0,*)' lcldm=',lcldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' icecldf=',icecldf(1,nlev-20:nlev) +! if (lprnt) write(0,*)' icldm=',icldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' qsfm=',qsfm(1,nlev-20:nlev) + + !> - Initialize local variables + + ! local physical properties + +! write(0,*)' in mg2 T=',t(1,:) +! write(0,*)' in mg2 P=',p(1,:),' r=',r + do k=1,nlev + do i=1,mgncol +! rho(i,k) = p(i,k) / (r*t(i,k)*(one+fv*q(i,k))) + rho(i,k) = p(i,k) / (r*t(i,k)) + rhoinv(i,k) = one / rho(i,k) + dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k) + mu(i,k) = 1.496E-6_r8 * t(i,k)*sqrt(t(i,k)) / (t(i,k) + 120._r8) + sc(i,k) = mu(i,k) / (rho(i,k)*dv(i,k)) + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof(i,k) = (rhosu*rhoinv(i,k))**0.54_r8 + + arn(i,k) = ar * rhof(i,k) + asn(i,k) = as * rhof(i,k) +!++ag if do hail then agn = ah *rhof else ag*rhof + agn(i,k) = agtmp * rhof(i,k) + acn(i,k) = g*rhow/(18._r8*mu(i,k)) + tx1 = (rhosu*rhoinv(i,k))**0.35_r8 + ain(i,k) = ai * tx1 + ajn(i,k) = aj * tx1 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Get humidity and saturation vapor pressures + +! do k=1,nlev +! do i=1,mgncol +! relvar(i,k) = relvar_i + accre_enhan(i,k) = accre_enhan_i +! call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) + esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) + qvl(i,k) = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) + + + ! make sure when above freezing that esi=esl, not active yet + if (t(i,k) >= tmelt) then + esi(i,k) = esl(i,k) + qvi(i,k) = qvl(i,k) + else +! call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) + esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) + qvi(i,k) = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) + end if + + ! Scale the water saturation values to reflect subgrid scale + ! ice cloud fraction, where ice clouds begin forming at a + ! gridbox average relative humidity of rhmini (not 1). + ! + ! NOTE: For subcolumns and other non-subgrid clouds, qsfm will be 1. + qvi(i,k) = qsfm(i,k) * qvi(i,k) +! esi(i,k) = qsfm(i,k) * esi(i,k) + qvl(i,k) = qsfm(i,k) * qvl(i,k) +! esl(i,k) = qsfm(i,k) * esl(i,k) + + relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) + end do + end do + + !=============================================== + + ! set mtime here to avoid answer-changing + mtime = deltat + + !> - initialize microphysics output + do k=1,nlev + do i=1,mgncol + qcsevap(i,k) = zero + qisevap(i,k) = zero + qvres(i,k) = zero + cmeitot(i,k) = zero + vtrmc(i,k) = zero + vtrmi(i,k) = zero + qcsedten(i,k) = zero + qisedten(i,k) = zero + qrsedten(i,k) = zero + qssedten(i,k) = zero +!++ag + qgsedten(i,k) = zero +!--ag + + + pratot(i,k) = zero + prctot(i,k) = zero + mnuccctot(i,k) = zero + mnuccttot(i,k) = zero + msacwitot(i,k) = zero + psacwstot(i,k) = zero + bergstot(i,k) = zero + bergtot(i,k) = zero + melttot(i,k) = zero + homotot(i,k) = zero + qcrestot(i,k) = zero + prcitot(i,k) = zero + praitot(i,k) = zero + qirestot(i,k) = zero + mnuccrtot(i,k) = zero +!++ag + mnuccritot(i,k) = zero +!--ag + + pracstot(i,k) = zero + meltsdttot(i,k) = zero + frzrdttot(i,k) = zero + mnuccdtot(i,k) = zero + +!++ag + psacrtot(i,k) = zero + pracgtot(i,k) = zero + psacwgtot(i,k) = zero + pgsacwtot(i,k) = zero + pgracstot(i,k) = zero + prdgtot(i,k) = zero +! eprdgtot(i,k) = zero + qmultgtot(i,k) = zero + qmultrgtot(i,k) = zero + npracgtot(i,k) = zero + nscngtot(i,k) = zero + ngracstot(i,k) = zero + nmultgtot(i,k) = zero + nmultrgtot(i,k) = zero + npsacwgtot(i,k) = zero +!need to zero these out to be totally switchable (for conservation) + psacr(i,k) = zero + pracg(i,k) = zero + psacwg(i,k) = zero + pgsacw(i,k) = zero + pgracs(i,k) = zero + + prdg(i,k) = zero +! eprdg(i,k) = zero + qmultg(i,k) = zero + qmultrg(i,k) = zero + npracg(i,k) = zero + nscng(i,k) = zero + ngracs(i,k) = zero + nmultg(i,k) = zero + nmultrg(i,k) = zero + npsacwg(i,k) = zero +!--ag + rflx(i,k+1) = zero + sflx(i,k+1) = zero + lflx(i,k+1) = zero + iflx(i,k+1) = zero +!++ag + gflx(i,k+1) = zero +!--ag + + !> - initialize precip output + + qrout(i,k) = zero + qsout(i,k) = zero + nrout(i,k) = zero + nsout(i,k) = zero +!++ag + qgout(i,k) = zero + ngout(i,k) = zero + dgout(i,k) = zero +!--ag + + ! for refl calc + rainrt(i,k) = zero + + !> - initialize rain size + rercld(i,k) = zero + + qcsinksum_rate1ord(i,k) = zero + + !> - initialize variables for trop_mozart + nevapr(i,k) = zero + prer_evap(i,k) = zero + evapsnow(i,k) = zero + am_evp_st(i,k) = zero + prain(i,k) = zero + prodsnow(i,k) = zero + cmeout(i,k) = zero + + precip_frac(i,k) = mincld + + lamc(i,k) = zero + + !> - initialize microphysical tendencies + + tlat(i,k) = zero + qvlat(i,k) = zero + qctend(i,k) = zero + qitend(i,k) = zero + qstend(i,k) = zero + qrtend(i,k) = zero + nctend(i,k) = zero + nitend(i,k) = zero + nrtend(i,k) = zero + nstend(i,k) = zero +!++ag + qgtend(i,k) = zero + ngtend(i,k) = zero +!--ag + + !> - initialize in-cloud and in-precip quantities to zero + qcic(i,k) = zero + qiic(i,k) = zero + qsic(i,k) = zero + qric(i,k) = zero +!++ag + qgic(i,k) = zero +!--ag + + + ncic(i,k) = zero + niic(i,k) = zero + nsic(i,k) = zero + nric(i,k) = zero +!++ag + ngic(i,k) = zero +!--ag + !> - initialize precip fallspeeds to zero + ums(i,k) = zero + uns(i,k) = zero + umr(i,k) = zero + unr(i,k) = zero +!++ag + umg(i,k) = zero + ung(i,k) = zero +!--ag + + !> - initialize limiter for output + qcrat(i,k) = one + + ! Many outputs have to be initialized here at the top to work around + ! ifort problems, even if they are always overwritten later. + effc(i,k) = ten + lamcrad(i,k) = zero + pgamrad(i,k) = zero + effc_fn(i,k) = ten + effi(i,k) = 25._r8 + sadice(i,k) = zero + sadsnow(i,k) = zero + deffi(i,k) = 50._r8 + + qrout2(i,k) = zero + nrout2(i,k) = zero + drout2(i,k) = zero + qsout2(i,k) = zero + nsout2(i,k) = zero + dsout(i,k) = zero + dsout2(i,k) = zero +!++ag + qgout2(i,k) = zero + ngout2(i,k) = zero + freqg(i,k) = zero + dgout2(i,k) = zero +!--ag + + freqr(i,k) = zero + freqs(i,k) = zero + + reff_rain(i,k) = zero + reff_snow(i,k) = zero +!++ag + reff_grau(i,k) = zero + lamg(i,k) = zero + n0g(i,k) = zero +!--ag + + refl(i,k) = -9999._r8 + arefl(i,k) = zero + areflz(i,k) = zero + frefl(i,k) = zero + csrfl(i,k) = zero + acsrfl(i,k) = zero + fcsrfl(i,k) = zero + + ncal(i,k) = zero + ncai(i,k) = zero + + nfice(i,k) = zero + npccn(i,k) = zero + enddo + enddo +!> - initialize ccn activated number tendency (\p npccn) + if (iccn == 1) then + do k=1,nlev + do i=1,mgncol + npccn(i,k) = npccnin(i,k) + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) + enddo + enddo + endif + + !> - initialize precip at surface + + do i=1,mgncol + prect(i) = zero + preci(i) = zero + enddo + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! get provisional droplet number after activation. This is used for + ! all microphysical process calculations, for consistency with update of + ! droplet mass before microphysics + + ! calculate potential for droplet activation if cloud water is present + ! tendency from activation (npccn) is read in from companion routine + + ! output activated liquid and ice (convert from #/kg -> #/m3) + !-------------------------------------------------- +! where (qc >= qsmall .and. lcldm > mincld) +! where (qc >= qsmall) +! npccn = max((npccnin*lcldm-nc)*oneodt, zero) +! nc = max(nc + npccn*deltat, zero) +! ncal = nc*rho/lcldm ! sghan minimum in #/cm3 +! elsewhere +! ncal = zero +! end where + +! if (lprnt) write(0,*)' nc1=',nc(1,:) + do k=1,nlev + do i=1,mgncol + if (qc(i,k) > qsmall .and. lcldm(i,k) >= mincld) then + npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) + nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, zero) + ncal(i,k) = nc(i,k) * rho(i,k) / lcldm(i,k) + else + ncal(i,k) = 0.0 + endif + enddo + enddo + + if (iccn == 1) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 +! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half + ncai(i,k) = naai(i,k)*rho(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + elseif (iccn == 2) then + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = naai(i,k)*rho(i,k) + ncai(i,k) = min(ncai(i,k), 710.0e3_r8) + naai(i,k) = ncai(i,k)*rhoinv(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + else + do k=1,nlev + do i=1,mgncol + if (t(i,k) < icenuct) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 + ncai(i,k) = min(ncai(i,k), 355.0e3_r8) + naai(i,k) = ncai(i,k)*rhoinv(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + + endif + + + !=============================================== + + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + ! + ! NOTE: If using gridbox average values, condensation will not occur until rh=1, + ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid + ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus + ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. + + !------------------------------------------------------- + + if (do_cldice) then + where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8) +! where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8 & +! .and. icldm > mincld ) + + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + nnuccd = (naai-ni/icldm)/mtime*icldm + nnuccd = max(nnuccd, zero) + nimax = naai*icldm + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd = nnuccd * mi0 + + elsewhere + nnuccd = zero + nimax = zero + mnuccd = zero + end where + + end if + + + !============================================================================= + do k=1,nlev + + do i=1,mgncol + + ! calculate instantaneous precip processes (melting and homogeneous freezing) + + ! melting of snow at +2 C + + if (t(i,k) > snowmelt) then + if (qs(i,k) > zero) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -(xlf/cpp) * qs(i,k) + if (t(i,k)+dum < snowmelt) then + dum = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) + else + dum = one + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1 = - minstsm(i,k) * (xlf*oneodt) + tlat(i,k) = tlat(i,k) + dum1 + meltsdttot(i,k) = meltsdttot(i,k) + dum1 + +! if (lprnt .and. k >=40) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& +! ' minstsm=',minstsm(i,k),' qs=',qs(i,k),' xlf=',xlf,' oneodt=',oneodt, & +! ' snowmelt=',snowmelt,' t=',t(i,k),' dum=',dum,' k=',k + + qs(i,k) = max(qs(i,k) - minstsm(i,k), zero) + ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) + qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) + nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) + end if + end if + + end do + end do +! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat +! if (lprnt) write(0,*)' qg1=',qg(1,:) + +!++ag + + if (do_graupel .or. do_hail) then +! melting of graupel at +2 C + + do k=1,nlev + do i=1,mgncol + + if (t(i,k) > snowmelt) then + if (qg(i,k) > zero) then + +! make sure melting graupel doesn't reduce temperature below threshold + dum = -(xlf/cpp) * qg(i,k) + if (t(i,k)+dum < snowmelt) then + dum = max(zero, min(one, (cpp/xlf)*(t(i,k)-snowmelt)/qg(i,k))) + else + dum = one + end if + + minstgm(i,k) = dum*qg(i,k) + ninstgm(i,k) = dum*ng(i,k) + + dum1 = - minstgm(i,k) * (xlf*oneodt) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + +! if (lprnt .and. k >=40) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& +! ' minstgm=',minstgm(i,k),' qg=',qg(i,k),' xlf=',xlf,' oneodt=',oneodt, & +! ' snowmelt=',snowmelt,' t=',t(i,k),' k=',k,' cpp=',cpp + + qg(i,k) = max(qg(i,k) - minstgm(i,k), zero) + ng(i,k) = max(ng(i,k) - ninstgm(i,k), zero) + qr(i,k) = max(qr(i,k) + minstgm(i,k), zero) + nr(i,k) = max(nr(i,k) + ninstgm(i,k), zero) + end if + end if + + end do + end do + endif + +! if (lprnt) write(0,*)' tlat1g=',tlat(1,:)*deltat +!--ag + + do k=1,nlev + do i=1,mgncol + ! freezing of rain at -5 C + + if (t(i,k) < rainfrze) then + + if (qr(i,k) > zero) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = (xlf/cpp) * qr(i,k) + if (t(i,k)+dum > rainfrze) then + dum = -(t(i,k)-rainfrze) * (cpp/xlf) + dum = min(one, max(zero, dum/qr(i,k))) + else + dum = one + end if + + minstrf(i,k) = dum*qr(i,k) + ninstrf(i,k) = dum*nr(i,k) + + ! heating tendency + dum1 = minstrf(i,k) * (xlf*oneodt) + tlat(i,k) = tlat(i,k) + dum1 + frzrdttot(i,k) = frzrdttot(i,k) + dum1 + + qr(i,k) = max(qr(i,k) - minstrf(i,k), zero) + nr(i,k) = max(nr(i,k) - ninstrf(i,k), zero) + +!++ag +! freeze rain to graupel not snow. + if(do_hail .or. do_graupel) then + qg(i,k) = max(qg(i,k) + minstrf(i,k), zero) + ng(i,k) = max(ng(i,k) + ninstrf(i,k), zero) + else + qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) + end if +!--ag + + end if + end if + end do + end do + +! if (lprnt) then +! write(0,*)' tlat2=',tlat(1,:)*deltat +! write(0,*)' lcldm=',lcldm(1,:) +! write(0,*)' qc=',qc(1,:) +! write(0,*)' nc=',nc(1,:) +! write(0,*)' qg2=',qg(1,:) +! endif + + do k=1,nlev + do i=1,mgncol + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + !------------------------------------------------------- + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + +! if (qc(i,k) >= qsmall .and. lcldm(i,k) > mincld) then + if (qc(i,k) >= qsmall) then + ! limit in-cloud values to 0.005 kg/kg + dum = one / lcldm(i,k) +! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg + ncic(i,k) = max(nc(i,k)*dum, zero) + + ! specify droplet concentration + if (nccons) then + ncic(i,k) = ncnst * rhoinv(i,k) + end if + else + qcic(i,k) = zero + ncic(i,k) = zero + end if + +! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then + if (qi(i,k) >= qsmall) then + dum = one / icldm(i,k) +! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg + qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg + niic(i,k) = max(ni(i,k)*dum, zero) + + ! switch for specification of cloud ice number + if (nicons) then + niic(i,k) = ninst * rhoinv(i,k) + end if + else + qiic(i,k) = zero + niic(i,k) = zero + end if + + end do + end do + + !======================================================================== + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so precip_frac will be correctly set below + ! and nothing extra needs to be done here + + precip_frac = cldm + + micro_vert_loop: do k=1,nlev + + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + if (k /= 1) then + where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) + precip_frac(:,k) = precip_frac(:,k-1) + end where + endif + + else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then + +!++ag add graupel to precip frac? + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave precip_frac as cloud fraction at current level + if (k /= 1) then +!++ag +! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) +!--ag + where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) + precip_frac(:,k) = max(precip_frac(:,k-1), precip_frac(:,k)) + end where + end if + + endif + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! cloud liquid + !------------------------------------------- + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' qcic=',qcic(1,k),' ncic=',ncic(1,k),' rho=',rho(1,k),' k=',k +! endif + call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' k=',k +! endif + + + !======================================================================== + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (.not. do_sb_physics) then + call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & + ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) + endif + + ! assign qric based on prognostic qr, using assumed precip fraction + ! note: this could be moved above for consistency with qcic and qiic calculations + do i=1,mgncol + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif +! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg + nric(i,k) = nr(i,k) * dum + + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + if(qric(i,k) < qsmall) then + qric(i,k) = zero + nric(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(i,k) = max(nric(i,k),zero) + enddo + ! Get size distribution parameters for cloud ice + + call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), mgncol, n0=n0i(:,k)) + + ! Alternative autoconversion + if (do_sb_physics) then + if (do_liq_liu) then + call liu_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k),mgncol) + else + call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) + endif + endif + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + do i=1,mgncol + if (qiic(i,k) >= qimax) then +! if (qi(i,k) >= qimax) then + ts_au_loc(i) = ts_au_min + elseif (qiic(i,k) <= qimin) then +! elseif (qi(i,k) <= qimin) then + ts_au_loc(i) = ts_au + else +! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv + ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv +! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) + endif +! if (ts_au_loc(i) > ts_au_min) ts_au_loc(i) = ts_au_loc(i)*min(five,sqrt(p(i,nlev)/p(i,k))) + enddo +! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qiic=',qiic(1,k),& +! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qi=',qi(1,k),& +! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' qimin=',qimin,' qimax=',qimax +! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' tsfac=',tsfac,' qimin=',qimin,' qimax=',qimax + + if(do_ice_gmao) then + call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & + n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) + else + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) + end if + !else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) + !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) + end if + + ! note, currently we don't have this + ! inside the do_cldice block, should be changed later + ! assign qsic based on prognostic qs, using assumed precip fraction + do i=1,mgncol + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif +! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg + nsic(i,k) = ns(i,k) * dum + + ! if precip mix ratio is zero so should number concentration + + if(qsic(i,k) < qsmall) then + qsic(i,k) = zero + nsic(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nsic(i,k) = max(nsic(i,k), zero) + +!++ also do this for graupel, which is assumed to be 'precip_frac' + qgic(i,k) = min(qg(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg) + ngic(i,k) = ng(i,k) * dum + + ! if precip mix ratio is zero so should number concentration + if (qgic(i,k) < qsmall) then + qgic(i,k) = zero + ngic(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + ngic(i,k) = max(ngic(i,k), zero) +!--ag + enddo + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & + lamr(:,k), mgncol, n0=n0r(:,k)) + + do i=1,mgncol + if (lamr(i,k) >= qsmall) then + dum = arn(i,k) / lamr(i,k)**br + dum1 = 9.1_r8*rhof(i,k) + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) + unr(i,k) = min(dum1, dum*gamma_br_plus1) + else + + umr(i,k) = zero + unr(i,k) = zero + endif + enddo + + !...................................................................... + ! snow + + call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & + lams(:,k), mgncol, n0=n0s(:,k)) + + do i=1,mgncol + if (lams(i,k) >= qsmall) then + + ! provisional snow number and mass weighted mean fallspeed (m/s) + + dum = asn(i,k) / lams(i,k)**bs + dum1 = 1.2_r8*rhof(i,k) + ums(i,k) = min(dum1, dum*gamma_bs_plus4*oneo6) + uns(i,k) = min(dum1, dum*gamma_bs_plus1) + + else + ums(i,k) = zero + uns(i,k) = zero + endif + enddo + + if (do_graupel .or. do_hail) then +!++ag +!use correct bg or bh (bgtmp=bg or bh) + !...................................................................... + ! graupel/hail + +!++AG SET rhog here and for mg_graupel_props? +! For now: rhog is constant. Set to same in micro_mg_utils.F90 +! Ideally: find a method to set once. (Hail = 400, Graupel = 500 from M2005) + +!mg,snow_props or mg_graupel props? + + call size_dist_param_basic(mg_graupel_props, qgic(:,k), ngic(:,k), & + lamg(:,k), mgncol, n0=n0g(:,k)) + + do i=1,mgncol + if (lamg(i,k) >= qsmall) then + + ! provisional graupel/hail number and mass weighted mean fallspeed (m/s) + + dum = agn(i,k) / lamg(i,k)**bgtmp + dum1 = 20._r8*rhof(i,k) + umg(i,k) = min(dum1, dum*gamma_bg_plus4*oneo6) + ung(i,k) = min(dum1, dum*gamma_bg_plus1) +! umg(i,k) = min(dum1, dum*gamma(four+bgtmp)*oneo6) +! ung(i,k) = min(dum1, dum*gamma(one+bgtmp)) + + else + umg(i,k) = zero + ung(i,k) = zero + endif + enddo +!--ag + endif + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' qcic=',qcic(1,k),' ncic=',ncic(1,k),' t=',t(1,k),' k=',k,& +! ' relvar=',relvar(1,k) +! endif + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' mnuccca=',mnuccc(1,k),' lcldm=',lcldm(1,k),' nnuccc=',nnuccc(1,k),' k=',k +! endif + + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing + +! where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8 .and. lcldm(:,k) > mincld) + where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8) + where (nnuccc(:,k)*lcldm(:,k) > nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) + end where + end where + +! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnuccc=',mnuccc(1,60:65) +! if (lprnt .and. k >= 100) write(0,*)' mnuccc=',mnuccc(1,k) +! if (lprnt) write(0,*)' mnuccc=',mnuccc(1,k) + + mdust = size(rndst,3) + call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & + nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) + +! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnucct=',mnucct(1,:) +! if (lprnt .and. k >= 100 ) write(0,*)' mnucct=',mnucct(1,k) +! if (lprnt) write(0,*)' mnucct=',mnucct(1,k) + + mnudep(:,k) = zero + nnudep(:,k) = zero + + !else + + ! Mass of droplets frozen is the average droplet mass, except + ! with two limiters: concentration must be at least 1/cm^3, and + ! mass must be at least the minimum defined above. + !mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + !mi0l = max(mi0l_min, mi0l) + + !where (qcic(:,k) >= qsmall) + !nnuccc(:,k) = frzimm(:,k)*1.0e6_r8*rhoinv(:,k) + !mnuccc(:,k) = nnuccc(:,k)*mi0l + + !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8*rhoinv(:,k) + !mnucct(:,k) = nnucct(:,k)*mi0l + + !nnudep(:,k) = frzdep(:,k)*1.0e6_r8*rhoinv(:,k) + !mnudep(:,k) = nnudep(:,k)*mi0 + !elsewhere + !nnuccc(:,k) = zero + !mnuccc(:,k) = zero + + !nnucct(:,k) = zero + !mnucct(:,k) = zero + + !nnudep(:,k) = zero + !mnudep(:,k) = zero + !end where + + end if + + else + do i=1,mgncol + mnuccc(i,k) = zero + nnuccc(i,k) = zero + mnucct(i,k) = zero + nnucct(i,k) = zero + mnudep(i,k) = zero + nnudep(i,k) = zero + enddo + end if + + call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & + nsagg(:,k), mgncol) + + call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & + qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & + psacws(:,k), npsacws(:,k), mgncol) + + if (do_cldice) then + call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) + else + nsacwi(:,k) = zero + msacwi(:,k) = zero + end if + + call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pracs(:,k), npracs(:,k), mgncol) + + call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & + mnuccr(:,k), nnuccr(:,k), mgncol) + + if (do_sb_physics) then + call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & + rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + else + call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & + ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) + endif + + call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) + + if (do_cldice) then + call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & + qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) + else + prai(:,k) = zero + nprai(:,k) = zero + end if + +!++ag Moved below graupel conditional, now two different versions +! if (.not. (do_hail .or. do_graupel)) then +! call evaporate_sublimate_precip(t(:,k), rho(:,k), & +! dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & +! lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & +! qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & +! pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) +! endif +!--ag + + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & + bergs(:,k), mgncol) +! if(lprnt) write(0,*)' bergs1=',bergs(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor +! if(lprnt) write(0,*)' t=',t(1,k),' rho=',rho(1,k),' dv=',dv(1,k),' mu=',mu(1,k),& +! 'qcic=',qcic(1,k),' qsic=',qsic(1,k),' qvl=',qvl(1,k),' qvi=',qvi(1,k), & +! ' mu=',mu(1,k),' sc=',sc(1,k),' asn=',asn(1,k),' lams=',lams(1,k),' n0s=',n0s(1,k),' ni=',ni(1,k) + + bergs(:,k) = bergs(:,k) * micro_mg_berg_eff_factor + + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & + icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & + berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) + +! if(lprnt) write(0,*)' t=',t(1,k),' k=',k,' q=',q(1,k),' qi=',qi(1,k),& +! ' ni=',ni(1,k),' icldm=',icldm(1,k),' rho=',rho(1,k),' dv=',dv(1,k),& +! ' qvl=',qvl(1,k),' qvi=',qvi(1,k),' berg=',berg(1,k),' vap_dep=',& +! vap_dep(1,k),' ice_sublim=',ice_sublim(1,k) +! if(lprnt) write(0,*)' berg1=',berg(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor + do i=1,mgncol +! sublimation should not exceed available ice + ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) + berg(i,k) = berg(i,k) * micro_mg_berg_eff_factor + if (ice_sublim(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then + nsubi(i,k) = sublim_factor * ice_sublim(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) + else + nsubi(i,k) = zero + endif + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(i,k) = zero + end do + + end if !do_cldice + !---PMC 12/3/12 + +!++ag Process rate calls for graupel here. +! (Should this be in do_cldice loop?) +!=================================================================== + + if(do_hail .or. do_graupel) then + call graupel_collecting_snow(qsic(:,k),qric(:,k),umr(:,k),ums(:,k), & + rho(:,k),lamr(:,k),n0r(:,k),lams(:,k),n0s(:,k), psacr(:,k), mgncol) + + call graupel_collecting_cld_water(qgic(:,k),qcic(:,k),ncic(:,k),rho(:,k), & + n0g(:,k),lamg(:,k),bgtmp,agn(:,k), psacwg(:,k), npsacwg(:,k), mgncol) + + call graupel_riming_liquid_snow(psacws(:,k),qsic(:,k),qcic(:,k),nsic(:,k), & + rho(:,k),rhosn,rhogtmp,asn(:,k),lams(:,k),n0s(:,k),deltat, & + pgsacw(:,k),nscng(:,k),mgncol) + +! if(lprnt .and. k >=100) then +! if(lprnt) then +! write(0,*)' k=',k,' qric=',qric(1,k),' qgic=',qgic(1,k),' umg=',umg(1,k),' umr=',umr(1,k),& +! ' ung=',ung(1,k),' unr=',unr(1,k),' rho=',rho(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k),& +! ' n0g=',n0g(1,k),' lamg=',lamg(1,k),' pracg=',pracg(1,k) +! endif + call graupel_collecting_rain(qric(:,k),qgic(:,k),umg(:,k), & + umr(:,k),ung(:,k),unr(:,k),rho(:,k),n0r(:,k),lamr(:,k),n0g(:,k), & + lamg(:,k), pracg(:,k),npracg(:,k),mgncol) +! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg=',pracg(1,k),' npracg=',npracg(1,k) + +!AG note: Graupel rain riming snow changes +! pracs, npracs, (accretion of rain by snow) psacr (collection of snow by rain) + +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& +! ' qsic=',qsic(1,k),' qric=',qric(1,k),' nric=',nric(1,k),' nsic=',nsic(1,k), & +! ' n0s=',n0s(1,k),' lams=',lams(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k), & +! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) + + call graupel_rain_riming_snow(pracs(:,k),npracs(:,k),psacr(:,k),qsic(:,k), & + qric(:,k),nric(:,k),nsic(:,k),n0s(:,k),lams(:,k),n0r(:,k),lamr(:,k), & + deltat,pgracs(:,k),ngracs(:,k),mgncol) +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& +! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) + + call graupel_rime_splintering(t(:,k),qcic(:,k),qric(:,k),qgic(:,k), & + psacwg(:,k),pracg(:,k),qmultg(:,k),nmultg(:,k),qmultrg(:,k), & + nmultrg(:,k),mgncol) + +! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg2=',pracg(1,k) +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracg2=',pracg(1,k) + + call evaporate_sublimate_precip_graupel(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), agn(:,k), bgtmp, & + qcic(:,k), qiic(:,k), qric(:,k), qsic(:,k), qgic(:,k), & + lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), lamg(:,k), n0g(:,k), & + pre(:,k), prds(:,k), prdg(:,k), am_evp_st(:,k), mgncol) + +!!Not used: part of above +!! call graupel_sublimate_evap(t(:,k),q(:,k),qgic(:,k),rho(:,k),n0g(:,k), & +!! lamg(:,k),qvi(:,k),dv(:,k),mu(:,k),sc(:,k),bgtmp,agn(:,k), & +!! prdg(:,k),eprdg(:,k),mgncol) + +!Checks for Debugging + +! if (minval(qmultg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, qmultg < 0 : min=",minval(qmultg(:,k)) +! +! if (minval(qmultrg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, qmultrg < 0 : min=",minval(qmultrg(:,k)) +! +! if (minval(pgracs(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, pgracs < 0 : min=",minval(pgracs(:,k)) +! +! if (minval(psacwg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, psacwg < 0 : min=",minval(psacwg(:,k)) +! +! if (minval(npsacwg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, npsacwg < 0 : min=",minval(npsacwg(:,k)) +! +! if (minval(pracg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, pracg < 0 : min=",minval(pracg(:,k)) +! +! if (maxval(prdg(:,k)).gt.0._r8) & +! write(iulog,*) "OOPS, prdg > 0 : max=",maxval(prdg(:,k)) +! +! if (minval(nmultg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nmultg < 0 : min=",minval(nmultg(:,k)) +! +! if (minval(nmultrg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nmultrg < 0 : min=",minval(nmultrg(:,k)) +! +! if (minval(ngracs(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, ngracs < 0 : min=",minval(ngracs(:,k)) +! +! if (minval(psacr(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, psacr < 0 : min=",minval(psacr(:,k)) +! +! if (minval(nscng(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nscng < 0 : min=",minval(nscng(:,k)) + + else +! Routine without Graupel (original) + call evaporate_sublimate_precip(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) + + + end if ! end do_graupel/hail loop +!--ag + + do i=1,mgncol + + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + !=================================================================== + + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! conservation of qc + !------------------------------------------------------------------- + +!++ag Add graupel tendencies for qc to equation ON +! dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & +! psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + dum = ( (prc(i,k) + pra(i,k) + mnuccc(i,k) + mnucct(i,k) + msacwi(i,k) & + + psacws(i,k) + bergs(i,k) + qmultg(i,k) + psacwg(i,k) + pgsacw(i,k))*lcldm(i,k) & + + berg(i,k) ) * deltat +!--ag + + if (dum > qc(i,k) .and. abs(dum) > qsmall) then +!++ag +! ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & +! msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm + + ratio = qc(i,k) / dum * omsm + + qmultg(i,k) = ratio * qmultg(i,k) + psacwg(i,k) = ratio * psacwg(i,k) + pgsacw(i,k) = ratio * pgsacw(i,k) +!--ag + prc(i,k) = ratio * prc(i,k) + pra(i,k) = ratio * pra(i,k) + mnuccc(i,k) = ratio * mnuccc(i,k) + mnucct(i,k) = ratio * mnucct(i,k) + msacwi(i,k) = ratio * msacwi(i,k) + psacws(i,k) = ratio * psacws(i,k) + bergs(i,k) = ratio * bergs(i,k) + berg(i,k) = ratio * berg(i,k) + qcrat(i,k) = ratio + else + qcrat(i,k) = one + end if + +! if(lprnt) write(0,*)' bergs2=',bergs(1,k),' k=',k,' ratio=',ratio + + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k) * (one-qcrat(i,k)) + end if + + end do + + do i=1,mgncol + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(one + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)*t(i,k)))*oneodt + dum = max(dum, zero) + if (dum1 > dum) then + ! Allocate the limited "dum" tendency to mnuccd and vap_dep + ! processes. Don't divide by cloud fraction; these are grid- + ! mean rates. + dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) + mnuccd(i,k) = dum*dum1 + vap_dep(i,k) = dum - mnuccd(i,k) + end if + end if + + end do + + do i=1,mgncol + + !=================================================================== + ! conservation of nc + !------------------------------------------------------------------- +!++ag NEW ONE ON +! dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & +! npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat + dum = (nprc1(i,k) + npra(i,k) + nnuccc(i,k) + nnucct(i,k) & + + npsacws(i,k) - nsubc(i,k) + npsacwg(i,k))*lcldm(i,k)*deltat +!--ag + + if (dum > nc(i,k) .and. abs(dum) > qsmall) then + ratio = nc(i,k) / dum * omsm +!++ag + npsacwg(i,k) = ratio * npsacwg(i,k) +!--ag + + nprc1(i,k) = ratio * nprc1(i,k) + npra(i,k) = ratio * npra(i,k) + nnuccc(i,k) = ratio * nnuccc(i,k) + nnucct(i,k) = ratio * nnucct(i,k) + npsacws(i,k) = ratio * npsacws(i,k) + nsubc(i,k) = ratio * nsubc(i,k) + end if + + mnuccri(i,k) = zero + nnuccri(i,k) = zero + + if (do_cldice) then + + ! freezing of rain to produce ice if mean rain size is smaller than Dcs + if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then + mnuccri(i,k) = mnuccr(i,k) + nnuccri(i,k) = nnuccr(i,k) + mnuccr(i,k) = zero + nnuccr(i,k) = zero + end if + end if + + end do + + do i=1,mgncol + + ! conservation of rain mixing ratio + !------------------------------------------------------------------- +!++ag Implemented change for graupel + dum1 = - pre(i,k) + pracs(i,k) + mnuccr(i,k) + mnuccri(i,k) & + + qmultrg(i,k) + pracg(i,k) + pgracs(i,k) + dum3 = dum1 * precip_frac(i,k) + dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) + dum = (dum3 - dum2) * deltat +!--ag + + ! note that qrtend is included below because of instantaneous freezing/melt + if (dum > qr(i,k) .and. dum1 >= qsmall .and. abs(dum3) > qsmall) then + ratio = (qr(i,k)*oneodt + dum2) / dum3 * omsm +!++ag + qmultrg(i,k) = ratio * qmultrg(i,k) + pracg(i,k) = ratio * pracg(i,k) + pgracs(i,k) = ratio * pgracs(i,k) +!--ag + pre(i,k) = ratio * pre(i,k) + pracs(i,k) = ratio * pracs(i,k) + mnuccr(i,k) = ratio * mnuccr(i,k) + mnuccri(i,k) = ratio * mnuccri(i,k) + end if + + end do + + do i=1,mgncol + + ! conservation of rain number + !------------------------------------------------------------------- + + ! Add evaporation of rain number. + if (pre(i,k) < zero) then + dum = max(-one, pre(i,k)*deltat/qr(i,k)) + nsubr(i,k) = dum*nr(i,k) * oneodt + else + nsubr(i,k) = zero + end if + + end do + + do i=1,mgncol + +!++ag IMplemented change for graupel +! dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) +! nprc(i,k)*lcldm(i,k))*deltat + + dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k) & + +npracg(i,k)+ngracs(i,k))*precip_frac(i,k) + dum2 = nprc(i,k)*lcldm(i,k) + dum = (dum1 - dum2) * deltat +!--ag + + if (dum > nr(i,k) .and. abs(dum1) > qsmall) then + ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm + +!++ag + npracg(i,k) = ratio * npracg(i,k) + ngracs(i,k) = ratio * ngracs(i,k) +!--ag + nragg(i,k) = ratio * nragg(i,k) + npracs(i,k) = ratio * npracs(i,k) + nnuccr(i,k) = ratio * nnuccr(i,k) + nsubr(i,k) = ratio * nsubr(i,k) + nnuccri(i,k) = ratio * nnuccri(i,k) + end if + + end do + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of qi + !------------------------------------------------------------------- + +!++ag + + dum1 = (prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k) +! dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & +! + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k) & +! + mnuccri(i,k)*precip_frac(i,k) + dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & + + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k) & + + (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k) + dum = (dum1 - dum2) * deltat +!-ag + + if (dum > qi(i,k) .and. abs(dum1) > qsmall) then + ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm + +!++ag +! Only sink terms are limited. +! qmultg(i,k) = ratio * qmultg(i,k) +! qmultrg(i,k) = ratio * qmultrg(i,k) +!--ag + prci(i,k) = ratio * prci(i,k) + prai(i,k) = ratio * prai(i,k) + ice_sublim(i,k) = ratio * ice_sublim(i,k) + end if + + end do + + end if + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of ni + !------------------------------------------------------------------- + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = zero + end if +!++ag + dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) +! dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & +! + nnuccri(i,k)*precip_frac(i,k) + dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & + + (nmultrg(i,k)+nnuccri(i,k))*precip_frac(i,k) +!--ag + dum = (dum1 - dum2) * deltat + + if (dum > ni(i,k) .and. abs(dum1) > qsmall) then + ratio = (ni(i,k)*oneodt + dum2) / dum1 * omsm + + nprci(i,k) = ratio * nprci(i,k) + nprai(i,k) = ratio * nprai(i,k) + nsubi(i,k) = ratio * nsubi(i,k) + end if + + end do + + end if + + do i=1,mgncol + + ! conservation of snow mixing ratio + !------------------------------------------------------------------- +!++ag + if (do_hail .or. do_graupel) then +!NOTE: mnuccr is moved to graupel when active +!psacr is a positive value, but a loss for snow +!HM: psacr is positive in dum (two negatives) + + dum1 = (psacr(i,k) - prds(i,k)) * precip_frac(i,k) + dum2 = pracs(i,k)*precip_frac(i,k) & + + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + if (dum > qs(i,k) .and. psacr(i,k)-prds(i,k) >= qsmall) then + ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm + psacr(i,k) = ratio * psacr(i,k) + prds(i,k) = ratio * prds(i,k) + endif + else + dum1 = - prds(i,k) * precip_frac(i,k) + dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then + ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm + prds(i,k) = ratio * prds(i,k) + endif + endif + +!--ag +! dum1 = - prds(i,k) * precip_frac(i,k) +! dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & +! + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) + +! dum = (dum1 - dum2) * deltat + +! if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then +! ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm + +! prds(i,k) = ratio * prds(i,k) +! end if + + end do + + do i=1,mgncol + + ! conservation of snow number + !------------------------------------------------------------------- + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + nsubs(i,k) = zero + + ratio = one +!++ag Watch sign of nscng and ngracs. What is sign of nnuccr? Negative? Should be a source here. + + if (do_hail .or. do_graupel) then +! dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) +! dum2 = nprci(i,k)*icldm(i,k) + nscng(i,k)*lcldm(i,k) +! dum = (dum1 - dum2) * deltat +! check here - this is slightly different from ag version - moorthi + + dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) & + - nscng(i,k)*lcldm(i,k) + dum2 = nprci(i,k)*icldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > ns(i,k) .and. abs(dum1) > qsmall) then + ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm + nscng(i,k) = ratio * nscng(i,k) + ngracs(i,k) = ratio * ngracs(i,k) + end if + + else + dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) + dum2 = nnuccr(i,k)*precip_frac(i,k) + nprci(i,k)*icldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > ns(i,k) .and. abs(dum1) > qsmall) then + ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm + end if + endif + nsubs(i,k) = ratio * nsubs(i,k) + nsagg(i,k) = ratio * nsagg(i,k) + + end do + +!++ag Graupel Conservation Checks +!------------------------------------------------------------------- + if (do_hail .or. do_graupel) then +! conservation of graupel mass +!------------------------------------------------------------------- + do i=1,mgncol + + dum1 = -prdg(i,k) * precip_frac(i,k) + dum2 = (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > qg(i,k) .and. abs(dum1) > qsmall) then + +! hm added +! note: prdg is always negative (like prds), so it needs to be subtracted in ratio + ratio = (qg(i,k)*oneodt + dum2) / dum1 * omsm + + prdg(i,k) = ratio * prdg(i,k) + + end if + + end do + +! conservation of graupel number: not needed, no sinks +!------------------------------------------------------------------- + end if +!--ag + + + do i=1,mgncol + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + +!++ag need to add graupel sublimation/evap here too (prdg)? May not need eprdg? +!++ag + tx1 = pre(i,k) * precip_frac(i,k) + tx2 = prds(i,k) * precip_frac(i,k) + tx6 = prdg(i,k) * precip_frac(i,k) + tx5 = tx2 + tx6 + tx3 = tx1 + tx5 + ice_sublim(i,k) + + if (tx3 < -1.e-20_r8) then + + tx4 = tx5 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) + qtmp = q(i,k) - (tx1 + tx4) * deltat + ttmp = t(i,k) + (tx1*xxlv + tx4*xxls) * (deltat/cpp) + + ! use rhw to allow ice supersaturation + ! call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) +! qvn = epsqs*esn/(p(i,k)-omeps*esn) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + tx4 = one / tx3 + dum1 = tx1 * tx4 + dum2 = tx2 * tx4 +!++ag + dum3 = tx6 * tx4 +!--ag + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + tx5 = (vap_dep(i,k)+mnuccd(i,k)) * deltat + qtmp = q(i,k) - tx5 + ttmp = t(i,k) + tx5 * (xxls/cpp) + + ! use rhw to allow ice supersaturation + !call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) +! qvn = epsqs*esn / (p(i,k)-omeps*esn) + + dum = min(zero, (qtmp-qvn)/(one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp))) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + if (precip_frac(i,k) > mincld) then + tx4 = oneodt / precip_frac(i,k) + else + tx4 = zero + endif + pre(i,k) = dum*dum1*tx4 + + ! do separately using RHI for prds and ice_sublim + !call qsat_ice(ttmp, p(i,k), esn, qvn) + esn = min(fpvsi(ttmp), p(i,k)) + qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) +! qvn = epsqs*esn / (p(i,k)-omeps*esn) + + + dum = min(zero, (qtmp-qvn)/(one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp))) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2*tx4 +!++ag + prdg(i,k) = dum*dum3*tx4 +!--ag +!++ag + ! don't divide ice_sublim by cloud fraction since it is grid-averaged +! dum1 = one - dum1 - dum2 + dum1 = one - dum1 - dum2 - dum3 +!--ag + ice_sublim(i,k) = dum*dum1*oneodt + end if + end if + + end do + + ! Big "administration" loop enforces conservation, updates variables + ! that accumulate over substeps, and sets output variables. + + do i=1,mgncol + + ! get tendencies due to microphysical conversion processes + !========================================================== + ! note: tendencies are multiplied by appropriate cloud/precip + ! fraction to get grid-scale values + ! note: vap_dep is already grid-average values + + ! The net tendencies need to be added to rather than overwritten, + ! because they may have a value already set for instantaneous + ! melting/freezing. + +!++ag +! qvlat(i,k) = qvlat(i,k) - (pre(i,k)+prds(i,k))*precip_frac(i,k)-& +! vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) + + qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k) & + -vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) & + -prdg(i,k)*precip_frac(i,k) + +! tlat(i,k) = tlat(i,k) + ((pre(i,k)*precip_frac(i,k)) & +! *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & +! ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & +! pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) + +! if (lprnt .and. k >= 60 .and. k <=65) & +! if (lprnt .and. k >= 100 ) & +! if (lprnt .and. abs(k-81) <5) & +! if (lprnt .and. k >= 60 ) & +! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& +! ' prds=',prds(i,k),' prdg=',prdg(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & +! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & +! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & +! ' psacwg=',psacwg(i,k),' qmultg=',qmultg(i,k),' pgsacw=',pgsacw(i,k),' mnuccr=',mnuccr(i,k), & +! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' pracg=',pracg(i,k),' pgracs=',pgracs(i,k), & +! ' qmultrg=',qmultrg(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls + + + tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & + ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+ & + mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & + ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacwg(i,k)+ & + qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ & + (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ & + berg(i,k))*xlf) + +! if (lprnt .and. k >= 100 ) write(0,*)' k=',k,' tlat=',tlat(i,k) +! if (lprnt) write(0,*)' k=',k,' tlat=',tlat(i,k) +! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) + +! qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & +! psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) + + qctend(i,k) = qctend(i,k) + & + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k) - & + psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k) + + if (do_cldice) then +! qitend(i,k) = qitend(i,k) + & +! (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & +! prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & +! mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) + + qitend(i,k) = qitend(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k)) * lcldm(i,k) & + + (-prci(i,k)-prai(i,k)) * icldm(i,k) & + + vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+mnuccd(i,k) & + + (mnuccri(i,k)+qmultrg(i,k)) * precip_frac(i,k) + + end if + +! qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & +! mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + + qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k)-qmultrg(i,k)-pracg(i,k)-pgracs(i,k))*precip_frac(i,k) + + +! qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & +! + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + if (do_hail.or.do_graupel) then + qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) + + qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & + + (prds(i,k)+pracs(i,k)-psacr(i,k))*precip_frac(i,k) + + else + !necessary since mnuccr moved to graupel + qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & + + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + end if +!--ag + + + cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! add output for cmei (accumulate) + cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! assign variables for trop_mozart, these are grid-average + !------------------------------------------------------------------- + ! evaporation/sublimation is stored here as positive term + +!++add evaporation/sublimation of graupel too? YES: After conservation checks. + +!++ag +!ADD GRAUPEL to evapsnow: prdg. (sign? same as prds: negative, so this is a positive number) +! evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) + evapsnow(i,k) = (-prds(i,k)-prdg(i,k)) * precip_frac(i,k) +!--ag + nevapr(i,k) = -pre(i,k) * precip_frac(i,k) + prer_evap(i,k) = -pre(i,k) * precip_frac(i,k) + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + +!++AG NEED TO MAKE CONSISTENT WITH BUDGETS + prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k) & + - (pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k) + if (do_hail .or. do_graupel) then +! Subtract PSACR here or not? Ask Hugh + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & + pracs(i,k)*precip_frac(i,k) + else + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & + (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + end if + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) + +!++AG NEED TO MAKE CONSITANT: PGSACW, PSACWG (check budgets)? More sink terms? Check. No. Just loss to precip. +!Ask Hugh +! qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) +!--ag + ! Avoid zero/near-zero division. + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) + + + ! microphysics output, note this is grid-averaged + pratot(i,k) = pra(i,k) * lcldm(i,k) + prctot(i,k) = prc(i,k) * lcldm(i,k) + mnuccctot(i,k) = mnuccc(i,k) * lcldm(i,k) + mnuccttot(i,k) = mnucct(i,k) * lcldm(i,k) + msacwitot(i,k) = msacwi(i,k) * lcldm(i,k) + psacwstot(i,k) = psacws(i,k) * lcldm(i,k) + bergstot(i,k) = bergs(i,k) * lcldm(i,k) + bergtot(i,k) = berg(i,k) + prcitot(i,k) = prci(i,k) * icldm(i,k) + praitot(i,k) = prai(i,k) * icldm(i,k) + mnuccdtot(i,k) = mnuccd(i,k) * icldm(i,k) + + pracstot(i,k) = pracs(i,k) * precip_frac(i,k) + mnuccrtot(i,k) = mnuccr(i,k) * precip_frac(i,k) +!++ag + mnuccritot(i,k) = mnuccri(i,k) * precip_frac(i,k) +!--ag + +!++ag Hail/Graupel tendencies for output + psacrtot(i,k) = psacr(i,k) * precip_frac(i,k) + pracgtot(i,k) = pracg(i,k) * precip_frac(i,k) + psacwgtot(i,k) = psacwg(i,k) * lcldm(i,k) + pgsacwtot(i,k) = pgsacw(i,k) * lcldm(i,k) + pgracstot(i,k) = pgracs(i,k) * precip_frac(i,k) + prdgtot(i,k) = prdg(i,k) * precip_frac(i,k) + qmultgtot(i,k) = qmultg(i,k) * lcldm(i,k) + qmultrgtot(i,k) = qmultrg(i,k) * precip_frac(i,k) + npracgtot(i,k) = npracg(i,k) * precip_frac(i,k) + nscngtot(i,k) = nscng(i,k) * lcldm(i,k) + ngracstot(i,k) = ngracs(i,k) * precip_frac(i,k) + nmultgtot(i,k) = nmultg(i,k) * lcldm(i,k) + nmultrgtot(i,k) = nmultrg(i,k) * precip_frac(i,k) + npsacwgtot(i,k) = npsacwg(i,k) * lcldm(i,k) +!--ag + +!++ag +! nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & +! - npra(i,k)-nprc1(i,k))*lcldm(i,k) + + nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + -npra(i,k)-nprc1(i,k)-npsacwg(i,k))*lcldm(i,k) + + if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = zero + end if +! nitend(i,k) = nitend(i,k) + nnuccd(i,k)+ & +! (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & +! nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) + + nitend(i,k) = nitend(i,k) + nnuccd(i,k) & + + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & + + (nsubi(i,k)-nprci(i,k)-nprai(i,k))*icldm(i,k) & + + (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k) + end if + + if(do_graupel.or.do_hail) then +! nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & +! + nprci(i,k)*icldm(i,k) + + nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)-ngracs(i,k))*precip_frac(i,k) & + + nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k) + + ngtend(i,k) = ngtend(i,k) + nscng(i,k)*lcldm(i,k) & + + (ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k) + + else + !necessary since mnuccr moved to graupel + nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & + + nprci(i,k)*icldm(i,k) + + end if + +! nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & +! - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) + + nrtend(i,k) = nrtend(i,k)+ nprc(i,k)*lcldm(i,k) & + + (nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & + -nnuccri(i,k)+nragg(i,k)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k) +!--ag + + ! make sure that ni at advanced time step does not exceed + ! maximum (existing N + source terms*dt), which is possible if mtime < deltat + ! note that currently mtime = deltat + !================================================================ + + if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then + nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) + end if + + end do + + ! End of "administration" loop + + end do micro_vert_loop ! end k loop + +! if (lprnt) write(0,*)' tlat3=',tlat(1,:)*deltat + !----------------------------------------------------- + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + do k=1,nlev + do i=1,mgncol + qrout(i,k) = qr(i,k) + nrout(i,k) = nr(i,k) * rho(i,k) + qsout(i,k) = qs(i,k) + nsout(i,k) = ns(i,k) * rho(i,k) +!++ag + qgout(i,k) = qg(i,k) + ngout(i,k) = ng(i,k) * rho(i,k) +!--ag + enddo + enddo + + ! calculate n0r and lamr from rain mass and number + ! divide by precip fraction to get in-precip (local) values of + ! rain mass and number, divide by rhow to get rain number in kg^-1 + + do k=1,nlev + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) + + enddo + ! Calculate rercld + + ! calculate mean size of combined rain and cloud water + + call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol, nlev) + + + ! Assign variables back to start-of-timestep values + ! Some state variables are changed before the main microphysics loop + ! to make "instantaneous" adjustments. Afterward, we must move those changes + ! back into the tendencies. + ! These processes: + ! - Droplet activation (npccn, impacts nc) + ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) + ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) + !================================================================================ + + do k=1,nlev + do i=1,mgncol + ! Re-apply droplet activation tendency + nc(i,k) = ncn(i,k) + nctend(i,k) = nctend(i,k) + npccn(i,k) + + ! Re-apply rain freezing and snow melting. + qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt + qs(i,k) = qsn(i,k) + + nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt + ns(i,k) = nsn(i,k) + + qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt + qr(i,k) = qrn(i,k) + + nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt + nr(i,k) = nrn(i,k) + +!++ag Re-apply graupel freezing/melting + qgtend(i,k) = qgtend(i,k) + (qg(i,k)-qgr(i,k)) * oneodt + qg(i,k) = qgr(i,k) + +! if (maxval(dum_2D-qg).gt.0._r8) & +! write(iulog,*) "OOPS, qg diff > 0 : max=",maxval(dum_2D-qg) +! if (minval(dum_2D-qg).lt.0._r8) & +! write(iulog,*) "OOPS, qg diff < 0 : min=",minval(dum_2D-qg) +! +! write(iulog,*) "Max qgtend: 1st = ",maxval(qgtend) +! write(iulog,*) "Min qgtend: 1st = ",minval(qgtend) +! write(iulog,*) "Max qvtend: 1st = ",maxval(qvlat) +! write(iulog,*) "Min qvtend: 1st = ",minval(qvlat) + + ngtend(i,k) = ngtend(i,k) + (ng(i,k)-ngr(i,k)) * oneodt + ng(i,k) = ngr(i,k) +!--ag + + !............................................................................. + + !================================================================================ + + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) + prain(i,k) = prain(i,k) + prodsnow(i,k) + + + enddo + enddo + + do k=1,nlev + + do i=1,mgncol + + ! calculate sedimentation for cloud water and ice +!++ag ! and Graupel (mg3) + !================================================================================ + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + if (lcldm(i,k) > mincld) then + tx1 = one / lcldm(i,k) + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) * tx1 + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst*rhoinv(i,k) + end if + else + dumc(i,k) = zero + dumnc(i,k) = zero + endif + if (icldm(i,k) > mincld) then + tx1 = one / icldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) * tx1 + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx1, zero) + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst*rhoinv(i,k) + end if + else + dumi(i,k) = zero + dumni(i,k) = zero + endif + if (precip_frac(i,k) > mincld) then + tx1 = one / precip_frac(i,k) + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) * tx1 + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) * tx1 + + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)*tx1, zero) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)*tx1, zero) + +!++ag Add graupel + dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 +! Moorthi testing + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 + dums(i,k) = dums(i,k) + tx2 + qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt + qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt + endif +! Moorthi testing + + dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)*tx1, zero) + ! switch for specification of droplet and crystal number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k) + endif +!--ag + else + dumr(i,k) = zero + dumr(i,k) = zero + dums(i,k) = zero + dumns(i,k) = zero +!++ag Add graupel + dumg(i,k) = zero + dumng(i,k) = zero + endif +!--ag + enddo + enddo + + do k=1,nlev + +! obtain new slope parameter to avoid possible singularity + + call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) + + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + +! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & +! lami(:,k), mgncol) +! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) +! fallspeed for snow + call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & + lams(:,k), mgncol) +! fallspeed for graupel/hail + if (do_graupel .or. do_hail) then + call size_dist_param_basic(mg_graupel_props, dumg(:,k), dumng(:,k), & + lamg(:,k), mgncol) + endif + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + grho = g*rho(i,k) + + if (dumc(i,k) >= qsmall) then + + tx1 = lamc(i,k)**bc + vtrmc(i,k) = acn(i,k)*gamma(pgam(i,k)+four+bc) & + / (tx1*gamma(pgam(i,k)+four)) + + fc(i,k) = grho * vtrmc(i,k) + fnc(i,k) = grho * acn(i,k)*gamma(pgam(i,k)+one+bc) & + / (tx1*gamma(pgam(i,k)+one)) + else + fc(i,k) = zero + fnc(i,k) = zero + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k) >= qsmall) then + + tx3 = one / lami(i,k) + tx1 = ain(i,k) * tx3**bi + tx2 = 1.2_r8*rhof(i,k) + vtrmi(i,k) = min(tx1*gamma_bi_plus4*oneo6, tx2) + + fi(i,k) = grho * vtrmi(i,k) + fni(i,k) = grho * min(tx1*gamma_bi_plus1, tx2) + + ! adjust the ice fall velocity for smaller (r < 20 um) ice + ! particles (blend over 18-20 um) + irad = (1.5_r8 * 1e6_r8) * tx3 + ifrac = min(one, max(zero, (irad-18._r8)*half)) + + if (ifrac < one) then + tx1 = ajn(i,k) / lami(i,k)**bj + vtrmi(i,k) = ifrac*vtrmi(i,k) + (one-ifrac) * min(tx1*gamma_bj_plus4*oneo6, tx2) + + fi(i,k) = grho * vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) + end if + else + fi(i,k) = zero + fni(i,k)= zero + end if + + ! fallspeed for rain + +! if (lamr(i,k) >= qsmall) then + if (dumr(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + tx1 = arn(i,k) / lamr(i,k)**br + tx2 = 9.1_r8*rhof(i,k) + umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) + unr(i,k) = min(tx1*gamma_br_plus1, tx2) + + fr(i,k) = grho * umr(i,k) + fnr(i,k) = grho * unr(i,k) + + else + fr(i,k) = zero + fnr(i,k) = zero + end if + + ! fallspeed for snow + +! if (lams(i,k) >= qsmall) then + if (dums(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + tx1 = asn(i,k) / lams(i,k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(i,k) = min(tx1*gamma_bs_plus4*oneo6, tx2) + uns(i,k) = min(tx1*gamma_bs_plus1, tx2) + + fs(i,k) = grho * ums(i,k) + fns(i,k) = grho * uns(i,k) + + else + fs(i,k) = zero + fns(i,k) = zero + end if + + if (do_graupel .or. do_hail) then +!++ag + ! fallspeed for graupel + + +! if (lamg(i,k) >= qsmall) then + if (dumg(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s) + tx1 = agn(i,k) / lamg(i,k)**bgtmp + tx2 = 20._r8 * rhof(i,k) + umg(i,k) = min(tx1*gamma_bg_plus4*oneo6, tx2) + ung(i,k) = min(tx1*gamma_bg_plus1, tx2) + + fg(i,k) = grho * umg(i,k) + fng(i,k) = grho * ung(i,k) + + else + fg(i,k) = zero + fng(i,k) = zero + end if + endif + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = qc(i,k) + qctend(i,k)*deltat + dumi(i,k) = qi(i,k) + qitend(i,k)*deltat + dumr(i,k) = qr(i,k) + qrtend(i,k)*deltat + dums(i,k) = qs(i,k) + qstend(i,k)*deltat + + dumnc(i,k) = nc(i,k) + nctend(i,k)*deltat + dumni(i,k) = ni(i,k) + nitend(i,k)*deltat + dumnr(i,k) = nr(i,k) + nrtend(i,k)*deltat + dumns(i,k) = ns(i,k) + nstend(i,k)*deltat +!++ag + dumg(i,k) = qg(i,k) + qgtend(i,k)*deltat + dumng(i,k) = ng(i,k) + ngtend(i,k)*deltat +!--ag + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + if (dumr(i,k) < qsmall) dumnr(i,k) = zero + if (dums(i,k) < qsmall) dumns(i,k) = zero + if (dumg(i,k) < qsmall) dumng(i,k) = zero + + enddo + end do !!! vertical loop + + do k=1,nlev + do i=1,mgncol + pdel_inv(i,k) = one / pdel(i,k) + enddo + enddo +! if (lprnt) write(0,*)' bef sedimentation dumc=',dumc(i,nlev-10:nlev) + + ! initialize nstep for sedimentation sub-steps + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + do i=1,mgncol + nlb = nlball(i) + nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + if (do_cldice) then + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + + do n = 1,nstep + + ! top of model + + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumi(i,k) = tx5 / (one + fi(i,k)*tx7) + tx6 = (dumi(i,k)-tx5) * oneodt + qitend(i,k) = qitend(i,k) + tx6 + tx5 = dumni(i,k) + dumni(i,k) = tx5 / (one + fni(i,k)*tx7) + nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qisedten(i,k) = qisedten(i,k) + tx6 + + falouti(k) = fi(i,k) * dumi(i,k) + faloutni(k) = fni(i,k) * dumni(i,k) + + iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux + + do k = 2,nlev + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + ! note: this is not an issue with precip, since we assume max overlap + + if (icldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (one + fi(i,k)*tx7) + tx6 = (dumi(i,k)-tx5) * oneodt + ! add fallout terms to eulerian tendencies + qitend(i,k) = qitend(i,k) + tx6 + tx5 = dumni(i,k) + dumni(i,k) = (tx5 + faloutni(k-1)*dum2) / (one + fni(i,k)*tx7) + nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt + + + qisedten(i,k) = qisedten(i,k) + tx6 ! sedimentation tendency for output + + + falouti(k) = fi(i,k) * dumi(i,k) + faloutni(k) = fni(i,k) * dumni(i,k) + + dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice + qisevap(i,k) = qisevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxls + + iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) + + end do + end if + +! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + + do n = 1,nstep + + ! top of model + k = 1 + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumc(i,k) = tx5 / (one + fc(i,k)*tx7) + tx6 = (dumc(i,k)-tx5) * oneodt + qctend(i,k) = qctend(i,k) + tx6 + tx5 = dumnc(i,k) + dumnc(i,k) = tx5 / (one + fnc(i,k)*tx7) + nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt + + + ! sedimentation tendency for output + qcsedten(i,k) = qcsedten(i,k) + tx6 + + faloutc(k) = fc(i,k) * dumc(i,k) + faloutnc(k) = fnc(i,k) * dumnc(i,k) + + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 + do k = 2,nlev + + if (lcldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (one + fc(i,k)*tx7) + tx6 = (dumc(i,k)-tx5) * oneodt + qctend(i,k) = qctend(i,k) + tx6 + tx5 = dumnc(i,k) + dumnc(i,k) = (tx5 + faloutnc(k-1)*dum2) / (one + fnc(i,k)*tx7) + nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt + + + + qcsedten(i,k) = qcsedten(i,k) + tx6 ! sedimentation tendency for output + + faloutc(k) = fc(i,k) * dumc(i,k) + faloutnc(k) = fnc(i,k) * dumnc(i,k) + + dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water + qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxlv + + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here + end do + + prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) + + end do +! if (lprnt) write(0,*)' tlat5=',tlat(1,:)*deltat +! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& +! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + nstep = min(nstep, nstep_def) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + +! if(lprnt) then +! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall +! write(0,*)' fr=',fr(i,:) +! write(0,*)' dumr=',dumr(i,:) +! endif + + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumr(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumr(i,k) = tx5 / (one + fr(i,k)*tx7) + tx6 = (dumr(i,k)-tx5) * oneodt + qrtend(i,k) = qrtend(i,k) + tx6 + tx5 = dumnr(i,k) + dumnr(i,k) = tx5 / (one + fnr(i,k)*tx7) + nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qrsedten(i,k) = qrsedten(i,k) + tx6 + + faloutr(k) = fr(i,k) * dumr(i,k) + faloutnr(k) = fnr(i,k) * dumnr(i,k) + + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 + + do k = 2,nlev + + tx5 = dumr(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumr(i,k) = (tx5 + faloutr(k-1)*tx7) / (one + fr(i,k)*tx7) + tx6 = (dumr(i,k)-tx5) * oneodt + qrtend(i,k) = qrtend(i,k) + tx6 + tx5 = dumnr(i,k) + dumnr(i,k) = (tx5 + faloutnr(k-1)*tx7) / (one + fnr(i,k)*tx7) + nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt + + qrsedten(i,k) = qrsedten(i,k) + tx6 ! sedimentation tendency for output + + faloutr(k) = fr(i,k) * dumr(i,k) + faloutnr(k) = fnr(i,k) * dumnr(i,k) + + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux + end do + + prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) + + end do + +! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dums(i,k) + tx7 = pdel_inv(i,k) * tx1 + dums(i,k) = tx5 / (one + fs(i,k)*tx7) + tx6 = (dums(i,k)-tx5) * oneodt + qstend(i,k) = qstend(i,k) + tx6 + tx5 = dumns(i,k) + dumns(i,k) = tx5 / (one + fns(i,k)*tx7) + nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qssedten(i,k) = qssedten(i,k) + tx6 + + falouts(k) = fs(i,k) * dums(i,k) + faloutns(k) = fns(i,k) * dumns(i,k) + + sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 + + do k = 2,nlev + + + tx5 = dums(i,k) + tx7 = pdel_inv(i,k) * tx1 + dums(i,k) = (tx5 + falouts(k-1)*tx7) / (one + fs(i,k)*tx7) + tx6 = (dums(i,k)-tx5) * oneodt + qstend(i,k) = qstend(i,k) + tx6 + tx5 = dumns(i,k) + dumns(i,k) = (tx5 + faloutns(k-1)*tx7) / (one + fns(i,k)*tx7) + nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt + + + qssedten(i,k) = qssedten(i,k) + tx6 ! sedimentation tendency for output + + falouts(k) = fs(i,k) * dums(i,k) + faloutns(k) = fns(i,k) * dumns(i,k) + + sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 ! Snow Flux + end do !! k loop + + prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) + + end do !! nstep loop + +! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) +! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) + + if (do_graupel .or. do_hail) then +!++ag Graupel Sedimentation + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fg(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fng(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumg(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumg(i,k) = tx5 / (one + fg(i,k)*tx7) + tx6 = (dumg(i,k)-tx5) * oneodt + qgtend(i,k) = qgtend(i,k) + tx6 + tx5 = dumng(i,k) + dumng(i,k) = tx5 / (one + fng(i,k)*tx7) + ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qgsedten(i,k) = qgsedten(i,k) + tx6 + + faloutg(k) = fg(i,k) * dumg(i,k) + faloutng(k) = fng(i,k) * dumng(i,k) + + gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux + + do k = 2,nlev + + tx5 = dumg(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumg(i,k) = (tx5 + faloutg(k-1)*tx7) / (one + fg(i,k)*tx7) + tx6 = (dumg(i,k)-tx5) * oneodt + ! add fallout terms to eulerian tendencies + qgtend(i,k) = qgtend(i,k) + tx6 + tx5 = dumng(i,k) + dumng(i,k) = (tx5 + faloutng(k-1)*tx7) / (one + fng(i,k)*tx7) + ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt + + + qgsedten(i,k) = qgsedten(i,k) + tx6 ! sedimentation tendency for output + + + faloutg(k) = fg(i,k) * dumg(i,k) + faloutng(k) = fng(i,k) * dumng(i,k) + + gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i) + faloutg(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + faloutg(nlev) * (tx3*0.001_r8) + + end do !! nstep loop + endif +! if (lprnt) write(0,*)' qgtnds=',qgtend(1,:) +!--ag + enddo ! end of i loop + ! end sedimentation + +! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) + +!++ag + dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) +! Moorthi testing + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 + dums(i,k) = dums(i,k) + tx2 + qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt + qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt + endif +! Moorthi testing + dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) +!--ag + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) + end if + +!++ag + ! switch for specification of graupel number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) + end if +!--ag + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + if (dumr(i,k) < qsmall) dumnr(i,k) = zero + if (dums(i,k) < qsmall) dumns(i,k) = zero +!++ag + if (dumg(i,k) < qsmall) dumng(i,k) = zero +!--ag + + enddo + + enddo + + ! calculate instantaneous processes (melting, homogeneous freezing) + !==================================================================== + + ! melting of snow at +2 C + do k=1,nlev + + do i=1,mgncol + + tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt + if (tx1 > zero) then + if (dums(i,k) > zero) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -(xlf/cpp) * dums(i,k) + if (tx1+dum < zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt + qstend(i,k) = qstend(i,k) - tx2*dums(i,k) + nstend(i,k) = nstend(i,k) - tx2*dumns(i,k) + qrtend(i,k) = qrtend(i,k) + tx2*dums(i,k) + nrtend(i,k) = nrtend(i,k) + tx2*dumns(i,k) + + dum1 = - xlf * tx2 * dums(i,k) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + end if + end if + enddo + enddo + + if (do_graupel .or. do_hail) then +!++ag + + ! melting of graupel at +2 C + + do k=1,nlev + + do i=1,mgncol + + tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt + if (tx1 > zero) then + if (dumg(i,k) > zero) then + + ! make sure melting graupel doesn't reduce temperature below threshold + dum = -(xlf/cpp) * dumg(i,k) + if (tx1+dum < zero) then + dum = max(zero, min(one, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt + + qgtend(i,k) = qgtend(i,k) - tx2*dumg(i,k) + ngtend(i,k) = ngtend(i,k) - tx2*dumng(i,k) + qrtend(i,k) = qrtend(i,k) + tx2*dumg(i,k) + nrtend(i,k) = nrtend(i,k) + tx2*dumng(i,k) + + dum1 = - xlf*tx2*dumg(i,k) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + end if + end if + enddo + enddo + +!--ag + endif + + do k=1,nlev + do i=1,mgncol + + ! freezing of rain at -5 C + + tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - rainfrze + if (tx1 < zero) then + + if (dumr(i,k) > zero) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = (xlf/cpp) * dumr(i,k) + if (tx1+dum > zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + tx2 = dum * oneodt + qrtend(i,k) = qrtend(i,k) - tx2 * dumr(i,k) + nrtend(i,k) = nrtend(i,k) - tx2 * dumnr(i,k) + + ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice + ! depending on mean rain size + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) + + if (lamr(i,k) < one/Dcs) then +!++ag freeze rain to graupel + if (do_hail .or. do_graupel) then + qgtend(i,k) = qgtend(i,k) + tx2 * dumr(i,k) + ngtend(i,k) = ngtend(i,k) + tx2 * dumnr(i,k) + else + qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) + nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) + end if +!--ag + else + qitend(i,k) = qitend(i,k) + tx2 * dumr(i,k) + nitend(i,k) = nitend(i,k) + tx2 * dumnr(i,k) + end if + ! heating tendency + dum1 = xlf*dum*dumr(i,k)*oneodt + frzrdttot(i,k) = dum1 + frzrdttot(i,k) + tlat(i,k) = dum1 + tlat(i,k) + + end if + end if + + enddo + enddo + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - tmelt + if (tx1 > zero) then + if (dumi(i,k) > zero) then + + ! limit so that melting does not push temperature below freezing + !----------------------------------------------------------------- + dum = -dumi(i,k)*xlf/cpp + if (tx1+dum < zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt + qctend(i,k) = qctend(i,k) + tx2*dumi(i,k) + + ! for output + melttot(i,k) = tx2*dumi(i,k) + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + nctend(i,k) = nctend(i,k) + three*tx2*dumi(i,k)/(four*pi*5.12e-16_r8*rhow) + + qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt + nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt + tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) + end if + end if + enddo + enddo + +! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat +! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-45:nlev)*deltat +! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-45:nlev)*deltat + + ! homogeneously freeze droplets at -40 C + !----------------------------------------------------------------- + + do k=1,nlev + do i=1,mgncol + tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - 233.15_r8 + if (tx1 < zero) then + if (dumc(i,k) > zero) then + + ! limit so that freezing does not push temperature above threshold + dum = (xlf/cpp) * dumc(i,k) + if (tx1+dum > zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt * dumc(i,k) + qitend(i,k) = tx2 + qitend(i,k) + homotot(i,k) = tx2 ! for output + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + + nitend(i,k) = nitend(i,k) + tx2*(three/(four*pi*1.563e-14_r8* 500._r8)) + qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt + nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt + tlat(i,k) = tlat(i,k) + xlf*tx2 + end if + end if + enddo + enddo + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + !----------------------------------------------------------------- + ! follow code similar to old CAM scheme + do k=1,nlev + do i=1,mgncol + + qtmp = q(i,k) + qvlat(i,k) * deltat + ttmp = t(i,k) + tlat(i,k) * (deltat/cpp) + + ! use rhw to allow ice supersaturation + !call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) +! qvn = epsqs*esn/(p(i,k)-omeps*esn) + + + if (qtmp > qvn .and. qvn > zero .and. allow_sed_supersat) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt + ! add to output cme + cmeout(i,k) = cmeout(i,k) + dum + ! now add to tendencies, partition between liquid and ice based on temperature + if (ttmp > 268.15_r8) then + dum1 = zero + ! now add to tendencies, partition between liquid and ice based on te + !------------------------------------------------------- + else if (ttmp < 238.15_r8) then + dum1 = one + else + dum1 = (268.15_r8-ttmp)/30._r8 + end if + + tx1 = xxls*dum1 + xxlv*(one-dum1) + dum = (qtmp-qvn)/(one+tx1*tx1*qvn/(cpp*rv*ttmp*ttmp)) * oneodt + tx2 = dum*(one-dum1) + qctend(i,k) = qctend(i,k) + tx2 + qcrestot(i,k) = tx2 ! for output + qitend(i,k) = qitend(i,k) + dum*dum1 + qirestot(i,k) = dum*dum1 + qvlat(i,k) = qvlat(i,k) - dum + ! for output + qvres(i,k) = -dum + tlat(i,k) = tlat(i,k) + dum*tx1 + end if + enddo + enddo + end if + +! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat + + ! calculate effective radius for pass to radiation code + !========================================================= + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + do k=1,nlev + do i=1,mgncol + if (lcldm(i,k) > mincld) then + tx1 = one / lcldm(i,k) + else + tx1 = zero + endif + if (icldm(i,k) > mincld) then + tx2 = one / icldm(i,k) + else + tx2 = zero + endif + if (precip_frac(i,k) > mincld) then + tx3 = one / precip_frac(i,k) + else + tx3 = zero + endif + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) * tx1 + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) * tx2 + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) * tx1 + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) * tx2 + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) * tx3 + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) * tx3 + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) * tx3 + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) * tx3 + +!++ag + dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) * tx3 + dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) * tx3 +!--ag + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst * rhoinv(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst * rhoinv(i,k) + end if + +!++ag + ! switch for specification of graupel number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) + end if +!--ag + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 +! dumc(i,k) = min(dumc(i,k), 5.e-3_r8) +! dumi(i,k) = min(dumi(i,k), 5.e-3_r8) + dumc(i,k) = min(dumc(i,k), 10.e-3_r8) + dumi(i,k) = min(dumi(i,k), 10.e-3_r8) + ! limit in-precip mixing ratios + dumr(i,k) = min(dumr(i,k), 10.e-3_r8) + dums(i,k) = min(dums(i,k), 10.e-3_r8) +!++ag + dumg(i,k) = min(dumg(i,k), 10.e-3_r8) +!--ag + enddo + enddo + ! cloud ice effective radius + !----------------------------------------------------------------- + + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (dumi(i,k) >= qsmall) then + + tx1 = dumni(i,k) + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k), dumni0) + + if (dumni(i,k) /= tx1) then + ! adjust number conc if needed to keep mean size in reasonable range + nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k)) * oneodt + end if + + tx1 = one / lami(i,k) +! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 + effi(i,k) = (three*1.e6_r8) * tx1 + sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 + + else + effi(i,k) = 50._r8 + sadice(i,k) = zero + end if + + ! ice effective diameter for david mitchell's optics + deffi(i,k) = effi(i,k) * (rhoi+rhoi)/rhows + enddo + enddo + !else + !do k=1,nlev + !do i=1,mgncol + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + !effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um + !deffi(i,k)=effi(i,k) * 2._r8 + !sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 + !enddo + !enddo + end if + + ! cloud droplet effective radius + !----------------------------------------------------------------- + do k=1,nlev + do i=1,mgncol + if (dumc(i,k) >= qsmall) then + + + ! switch for specification of droplet and crystal number + if (nccons) then + ! make sure nc is consistence with the constant N by adjusting tendency, need + ! to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet size is + ! out of bounds + + nctend(i,k) = (ncnst*rhoinv(i,k)*lcldm(i,k)-nc(i,k)) * oneodt + + end if + + dum = dumnc(i,k) + + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + if (dum /= dumnc(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k)) * oneodt + end if + + effc(i,k) = (half*1.e6_r8) * (pgam(i,k)+three) / lamc(i,k) + !assign output fields for shape here + lamcrad(i,k) = lamc(i,k) + pgamrad(i,k) = pgam(i,k) + + + ! recalculate effective radius for constant number, in order to separate + ! first and second indirect effects + !====================================== + ! assume constant number of 10^8 kg-1 + + dumnc(i,k) = 1.e8_r8 + + ! Pass in "false" adjust flag to prevent number from being changed within + ! size distribution subroutine. + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + effc_fn(i,k) = (half*1.e6_r8) * (pgam(i,k)+three)/lamc(i,k) + + else + effc(i,k) = ten + lamcrad(i,k) = zero + pgamrad(i,k) = zero + effc_fn(i,k) = ten + end if + enddo + enddo + ! recalculate 'final' rain size distribution parameters + ! to ensure that rain size is in bounds, adjust rain number if needed + do k=1,nlev + do i=1,mgncol + + if (dumr(i,k) >= qsmall) then + + dum = dumnr(i,k) + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) + + if (dum /= dumnr(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt + end if + + end if + enddo + enddo + ! recalculate 'final' snow size distribution parameters + ! to ensure that snow size is in bounds, adjust snow number if needed + do k=1,nlev + do i=1,mgncol + if (dums(i,k) >= qsmall) then + + dum = dumns(i,k) + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k), n0=dumns0) + + if (dum /= dumns(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k)) * oneodt + end if + + tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) + sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 + + end if + + + end do ! vertical k loop + enddo + do k=1,nlev + do i=1,mgncol + ! if updated q (after microphysics) is zero, then ensure updated n is also zero + !================================================================================= + if (qc(i,k)+qctend(i,k)*deltat < qsmall) nctend(i,k) = -nc(i,k) * oneodt + if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat < qsmall) nitend(i,k) = -ni(i,k) * oneodt + if (qr(i,k)+qrtend(i,k)*deltat < qsmall) nrtend(i,k) = -nr(i,k) * oneodt + if (qs(i,k)+qstend(i,k)*deltat < qsmall) nstend(i,k) = -ns(i,k) * oneodt +!++ag + if (qg(i,k)+qgtend(i,k)*deltat < qsmall) ngtend(i,k) = -ng(i,k) * oneodt +!--ag + + end do + + end do + + ! DO STUFF FOR OUTPUT: + !================================================== + + do k=1,nlev + do i=1,mgncol + + ! qc and qi are only used for output calculations past here, + ! so add qctend and qitend back in one more time + qc(i,k) = qc(i,k) + qctend(i,k)*deltat + qi(i,k) = qi(i,k) + qitend(i,k)*deltat + + ! averaging for snow and rain number and diameter + !-------------------------------------------------- + + ! drout2/dsout2: + ! diameter of rain and snow + ! dsout: + ! scaled diameter of snow (passed to radiation in CAM) + ! reff_rain/reff_snow: + ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual + + if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then + qrout2(i,k) = qrout(i,k) * precip_frac(i,k) + nrout2(i,k) = nrout(i,k) * precip_frac(i,k) + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just drout2 times constants. + drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) + freqr(i,k) = precip_frac(i,k) + + reff_rain(i,k) = (1.e6_r8*1.5_r8) * drout2(i,k) + else + qrout2(i,k) = zero + nrout2(i,k) = zero + drout2(i,k) = zero + freqr(i,k) = zero + reff_rain(i,k) = zero + endif + + if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then + qsout2(i,k) = qsout(i,k) * precip_frac(i,k) + nsout2(i,k) = nsout(i,k) * precip_frac(i,k) + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just dsout2 times constants. + dsout2(i,k) = avg_diameter(qsout(i,k), nsout(i,k), rho(i,k), rhosn) + freqs(i,k) = precip_frac(i,k) + + dsout(i,k) = three*rhosn/rhows*dsout2(i,k) + + reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) + else + dsout(i,k) = zero + qsout2(i,k) = zero + nsout2(i,k) = zero + dsout2(i,k) = zero + freqs(i,k) = zero + reff_snow(i,k) = zero + endif + + enddo + enddo + + ! analytic radar reflectivity + !-------------------------------------------------- + ! formulas from Matthew Shupe, NOAA/CERES + ! *****note: radar reflectivity is local (in-precip average) + ! units of mm^6/m^3 + + do k=1,nlev + do i = 1,mgncol +! if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten .and. lcldm(i,k) > mincld) then + if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten) then + tx1 = rho(i,k) / lcldm(i,k) + tx2 = 1000._r8 * qc(i,k) * tx1 + dum = tx2 * tx2 * lcldm(i,k) & + /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)*tx1*1.e-6_r8*precip_frac(i,k)) +! dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & +! /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) + else + dum = zero + end if +! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then + if (qi(i,k) >= qsmall) then +! dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) + dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*10000._r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) + else + dum1 = zero + end if + + if (qsout(i,k) >= qsmall) then +! dum1 = dum1 + (qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(one/0.63_r8) + dum1 = dum1 + (qsout(i,k)*rho(i,k)*10000._r8)**(one/0.63_r8) + end if + + refl(i,k) = dum + dum1 + + ! add rain rate, but for 37 GHz formulation instead of 94 GHz + ! formula approximated from data of Matrasov (2007) + ! rainrt is the rain rate in mm/hr + ! reflectivity (dum) is in DBz + + if (rainrt(i,k) >= 0.001_r8) then + dum = rainrt(i,k) * rainrt(i,k) + dum = log10(dum*dum*dum) + 16._r8 + + ! convert from DBz to mm^6/m^3 + + dum = ten**(dum/ten) + else + ! don't include rain rate in R calculation for values less than 0.001 mm/hr + dum = zero + end if + + ! add to refl + + refl(i,k) = refl(i,k) + dum + + !output reflectivity in Z. + areflz(i,k) = refl(i,k) * precip_frac(i,k) + + ! convert back to DBz + + if (refl(i,k) > minrefl) then + refl(i,k) = ten*log10(refl(i,k)) + else + refl(i,k) = -9999._r8 + end if + + !set averaging flag + if (refl(i,k) > mindbz) then + arefl(i,k) = refl(i,k) * precip_frac(i,k) + frefl(i,k) = precip_frac(i,k) + else + arefl(i,k) = zero + areflz(i,k) = zero + frefl(i,k) = zero + end if + + ! bound cloudsat reflectivity + + csrfl(i,k) = min(csmax,refl(i,k)) + + !set averaging flag + if (csrfl(i,k) > csmin) then + acsrfl(i,k) = refl(i,k) * precip_frac(i,k) + fcsrfl(i,k) = precip_frac(i,k) + else + acsrfl(i,k) = zero + fcsrfl(i,k) = zero + end if + + end do + end do + + do k=1,nlev + do i = 1,mgncol + !redefine fice here.... + tx2 = qsout(i,k) + qi(i,k) + tx1 = tx2 + qrout(i,k) + qc(i,k) + if ( tx2 > qsmall .and. tx1 > qsmall) then + nfice(i,k) = min(tx2/tx1, one) + else + nfice(i,k) = zero + endif + enddo + enddo + +end subroutine micro_mg_tend +!> @} + +!======================================================================== +!OUTPUT CALCULATIONS +!======================================================================== + +!>\ingroup mg3_mp +!! This subroutine calculates effective radii for rain and cloud. +subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) + 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 + + integer :: i, k + + do k=1,nlev + do i=1,mgncol + ! Rain drops + if (lamr(i,k) > zero) then + Atmp = n0r(i,k) * (half*pi) / (lamr(i,k)*lamr(i,k)*lamr(i,k)) + else + Atmp = zero + end if + + ! Add cloud drops + if (lamc(i,k) > zero) then + Atmp = Atmp + ncic(i,k) * pi * rising_factorial(pgam(i,k)+one, 2) & + / (four*lamc(i,k)*lamc(i,k)) + end if + + if (Atmp > zero) then + rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) + end if + enddo + enddo +end subroutine calc_rercld + +!======================================================================== + +end module micro_mg3_0 +!>@} From 539afef69b69458707ea9153ef683fbd8f17cdbc Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 24 Sep 2020 21:36:12 -0400 Subject: [PATCH 004/165] fix a typo in comment --- physics/micro_mg3_0.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index b50980da7..ad5166bd3 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -1092,7 +1092,7 @@ subroutine micro_mg_tend ( & ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) ! ts_au_min=180.0 - real(r8), parameter :: pmin_sed = 5000.0 ! layer pressur in Pa below which + real(r8), parameter :: pmin_sed = 5000.0 ! layer pressure in Pa below which ! sedimentation calcuation is done ! integer, parameter :: nstep_fac=10 ! factor for definng nstep_def integer, parameter :: nstep_fac=5 ! factor for definng nstep_def From ff0c7667d0ec892580a8b45de921d23ae674b450 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 19 Oct 2020 07:20:17 -0400 Subject: [PATCH 005/165] fixing issues related min_seaice and min_lakeice in surface composite --- physics/GFS_surface_composites.F90 | 119 ++++++++++++++++++++-------- physics/GFS_surface_composites.meta | 8 ++ physics/GFS_surface_generic.F90 | 22 ++--- 3 files changed, 104 insertions(+), 45 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 9da662e65..212876b37 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -24,15 +24,15 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & - zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat,& - tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & - qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & + zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, semis_rad, semis_wat, semis_lnd, semis_ice,& + qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & min_lakeice, min_seaice, errmsg, errflg) implicit none @@ -55,7 +55,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(im), intent(inout) :: islmsk + integer, dimension(im), intent(inout) :: islmsk, islmsk_cice real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice @@ -79,34 +79,56 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (flag_cice(i)) then if (cice(i) >= min_seaice) then icy(i) = .true. - if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + if (cice(i) < one) then + wet(i) = .true. ! some open ocean exists + tsfco(i) = max(tsfco(i), tisfc(i), tgice) + endif else cice(i) = zero flag_cice(i) = .false. -! islmsk_cice(i) = 0 -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists + islmsk_cice(i) = 0 + islmsk(i) = 0 + wet(i) = .true. ! open ocean endif else - if (cice(i) >= min_lakeice) then + if (oceanfrac(i) > zero .and. .not. cplflx) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + if (cice(i) < one) then + wet(i) = .true. ! some open ocean exists + tsfco(i) = max(tsfco(i), tisfc(i), tgice) + endif + islmsk_cice(i) = 2 + islmsk(i) = 2 + else + cice(i) = zero + icy(i) = .false. + wet(i) = .true. ! open ocean + islmsk_cice(i) = 0 + islmsk(i) = 0 + endif + elseif (cice(i) >= min_lakeice) then icy(i) = .true. - if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists - islmsk(i) = 2 + if (cice(i) < one) then + wet(i) = .true. ! some open lake exists + tsfco(i) = max(tisfc(i), tgice) + endif + islmsk_cice(i) = 2 + islmsk(i) = 2 else cice(i) = zero -! islmsk(i) = 0 - wet(i) = .true. ! some open ocean/lake water exists - endif - endif - if (wet(i) .and. .not. cplflx) then - if (oceanfrac(i) > zero) then - tsfco(i) = max(tsfco(i), tisfc(i), tgice) - elseif (icy(i)) then - tsfco(i) = max(tisfc(i), tgice) + icy(i) = .false. + wet(i) = .true. ! open lake + islmsk_cice(i) = 0 + islmsk(i) = 0 endif endif else cice(i) = zero + icy(i) = .false. + wet(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 endif enddo @@ -114,10 +136,13 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx do i = 1, IM if (islmsk(i) == 1) then -! tsfcl(i) = tsfc(i) +! tsfcl(i) = tsfc(i) dry(i) = .true. frland(i) = one cice(i) = zero + icy(i) = .false. + wet(i) = .false. + islmsk_cice(i) = 1 else frland(i) = zero if (flag_cice(i)) then @@ -127,19 +152,45 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 + islmsk_cice(i) = 0 + icy(i) = .false. + wet(i) = .true. endif else - if (cice(i) > min_lakeice) then + if (oceanfrac(i) > zero .and. .not. cplflx) then + if (cice(i) > min_seaice) then + icy(i) = .true. + wet(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open ocean exists + tsfco(i) = max(tisfc(i), tgice) + endif + islmsk(i) = 2 + islmsk_cice(i) = 2 + else + cice(i) = zero + icy(i) = .false. + wet(i) = .true. + islmsk(i) = 0 + islmsk_cice(i) = 0 + endif + elseif (cice(i) > min_lakeice) then icy(i) = .true. + wet(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake exists + tsfco(i) = max(tisfc(i), tgice) + endif + islmsk(i) = 2 + islmsk_cice(i) = 2 else cice(i) = zero - islmsk(i) = 0 + icy(i) = .false. + wet(i) = .true. + islmsk(i) = 0 + islmsk_cice(i) = 0 endif endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif endif enddo endif @@ -202,7 +253,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! to prepare to separate lake from ocean under water category do i = 1, im - if(lkm == 1) then + if (lkm == 1) then if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then lake(i) = .true. else diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 71765b9a2..4cfdf093b 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -508,6 +508,14 @@ type = integer intent = in optional = F +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F [semis_rad] standard_name = surface_longwave_emissivity long_name = surface lw emissivity in fraction diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index b6d4dfb02..519336860 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -109,25 +109,25 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, lndp_vgf=-999. if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') + case ('vgf') ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff do i=1,im call cdfnor(sfc_wts(i,k),cdfz) vegf1d(i) = cdfz enddo lndp_vgf = lndp_prt_list(k) - end select - enddo + end select + enddo endif ! End of stochastic physics / surface perturbation From 12a2b9c5477e4f964a840e8845b4b7192dfc8dfb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 19 Oct 2020 10:11:20 -0400 Subject: [PATCH 006/165] adding Shan's slmsk change to GFS_surface_composites - does not change result in non fractional grid result --- physics/GFS_surface_composites.F90 | 11 ++++++----- physics/GFS_surface_composites.meta | 13 +++++++++++-- 2 files changed, 17 insertions(+), 7 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 212876b37..a73cf25e5 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -31,8 +31,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, semis_rad, semis_wat, semis_lnd, semis_ice,& - qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, & + semis_ice, qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & min_lakeice, min_seaice, errmsg, errflg) implicit none @@ -57,7 +57,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx real(kind=kind_phys), intent(in ) :: tgice integer, dimension(im), intent(inout) :: islmsk, islmsk_cice real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad - real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice + real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice ! CCPP error handling @@ -174,7 +174,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk(i) = 0 islmsk_cice(i) = 0 endif - elseif (cice(i) > min_lakeice) then + elseif (cice(i) >= min_lakeice) then icy(i) = .true. wet(i) = .false. if (cice(i) < one) then @@ -249,6 +249,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_ice(i) = qss(i) hflx_ice(i) = hflx(i) endif + slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category @@ -601,7 +602,7 @@ subroutine GFS_surface_composites_post_run ( zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) elseif (wet(i)) then - if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 4cfdf093b..7ce84b92e 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -506,7 +506,7 @@ units = flag dimensions = (horizontal_loop_extent) type = integer - intent = in + intent = inout optional = F [islmsk_cice] standard_name = sea_land_ice_mask_cice @@ -514,7 +514,16 @@ units = flag dimensions = (horizontal_loop_extent) type = integer - intent = out + intent = inout + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout optional = F [semis_rad] standard_name = surface_longwave_emissivity From b665a5f83902d4f946bd119a9a137fd2f54fb6ad Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 20 Oct 2020 19:56:41 -0400 Subject: [PATCH 007/165] updating GFS_surface_composites.F90 to make coupled restart reprodicible --- physics/GFS_surface_composites.F90 | 118 ++++++++--------------------- 1 file changed, 32 insertions(+), 86 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index a73cf25e5..d7cd13eea 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -24,15 +24,15 @@ end subroutine GFS_surface_composites_pre_finalize !> \section arg_table_GFS_surface_composites_pre_run Argument Table !! \htmlinclude GFS_surface_composites_pre_run.html !! - subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & - zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & - tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, & - semis_ice, qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & + zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & + qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & min_lakeice, min_seaice, errmsg, errflg) implicit none @@ -76,59 +76,31 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx frland(i) = landfrac(i) if (frland(i) > zero) dry(i) = .true. if (frland(i) < one) then - if (flag_cice(i)) then + if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open ocean exists - tsfco(i) = max(tsfco(i), tisfc(i), tgice) - endif else cice(i) = zero flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 - wet(i) = .true. ! open ocean endif else - if (oceanfrac(i) > zero .and. .not. cplflx) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open ocean exists - tsfco(i) = max(tsfco(i), tisfc(i), tgice) - endif - islmsk_cice(i) = 2 - islmsk(i) = 2 - else - cice(i) = zero - icy(i) = .false. - wet(i) = .true. ! open ocean - islmsk_cice(i) = 0 - islmsk(i) = 0 - endif - elseif (cice(i) >= min_lakeice) then + if (cice(i) >= min_lakeice) then icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open lake exists - tsfco(i) = max(tisfc(i), tgice) - endif - islmsk_cice(i) = 2 - islmsk(i) = 2 + islmsk(i) = 2 else cice(i) = zero - icy(i) = .false. - wet(i) = .true. ! open lake - islmsk_cice(i) = 0 - islmsk(i) = 0 +! islmsk(i) = 0 endif + islmsk_cice(i) = islmsk(i) + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif else cice(i) = zero - icy(i) = .false. - wet(i) = .false. - islmsk_cice(i) = 0 - islmsk(i) = 0 endif enddo @@ -136,60 +108,34 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx do i = 1, IM if (islmsk(i) == 1) then -! tsfcl(i) = tsfc(i) +! tsfcl(i) = tsfc(i) dry(i) = .true. frland(i) = one cice(i) = zero - icy(i) = .false. - wet(i) = .false. - islmsk_cice(i) = 1 else frland(i) = zero - if (flag_cice(i)) then - if (cice(i) > min_seaice) then + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then icy(i) = .true. else cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 - icy(i) = .false. - wet(i) = .true. endif else - if (oceanfrac(i) > zero .and. .not. cplflx) then - if (cice(i) > min_seaice) then - icy(i) = .true. - wet(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open ocean exists - tsfco(i) = max(tisfc(i), tgice) - endif - islmsk(i) = 2 - islmsk_cice(i) = 2 - else - cice(i) = zero - icy(i) = .false. - wet(i) = .true. - islmsk(i) = 0 - islmsk_cice(i) = 0 - endif - elseif (cice(i) >= min_lakeice) then + if (cice(i) >= min_lakeice) then icy(i) = .true. - wet(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake exists - tsfco(i) = max(tisfc(i), tgice) - endif - islmsk(i) = 2 - islmsk_cice(i) = 2 else cice(i) = zero - icy(i) = .false. - wet(i) = .true. - islmsk(i) = 0 - islmsk_cice(i) = 0 + flag_cice(i) = .false. + islmsk(i) = 0 endif + islmsk_cice(i) = islmsk(i) + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake water exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif enddo @@ -249,12 +195,12 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_ice(i) = qss(i) hflx_ice(i) = hflx(i) endif - slmsk(i) = islmsk(i) + slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category do i = 1, im - if (lkm == 1) then + if(lkm == 1) then if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then lake(i) = .true. else @@ -602,7 +548,7 @@ subroutine GFS_surface_composites_post_run ( zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) elseif (wet(i)) then - if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice + if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) From 38094d64ec97cbbef88b88f0e9a6de32893eeefe Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 20 Oct 2020 21:27:34 -0400 Subject: [PATCH 008/165] some additional updates --- physics/GFS_surface_composites.F90 | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index d7cd13eea..f0f95a022 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -85,6 +85,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk_cice(i) = 0 islmsk(i) = 0 endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake water exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif else if (cice(i) >= min_lakeice) then icy(i) = .true. @@ -94,10 +98,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake exists - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake exists + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif endif else cice(i) = zero @@ -123,6 +127,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk(i) = 0 islmsk_cice(i) = 0 endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake water exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif else if (cice(i) >= min_lakeice) then icy(i) = .true. @@ -132,10 +140,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + if (cice(i) < one) then + wet(i) = .true. ! some open ocean/lake water exists + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif endif endif enddo From 109ec799cdc16c5d5a2c43b7bb771ec4cccb4cba Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 22 Oct 2020 20:03:08 -0400 Subject: [PATCH 009/165] some updated comments --- physics/GFS_surface_composites.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index f0f95a022..30695136f 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -86,7 +86,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk(i) = 0 endif if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists + wet(i) = .true. ! some open ocean if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif else @@ -99,7 +99,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx endif islmsk_cice(i) = islmsk(i) if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake exists + wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif @@ -128,7 +128,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk_cice(i) = 0 endif if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists + wet(i) = .true. ! some open ocean if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif else @@ -141,7 +141,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx endif islmsk_cice(i) = islmsk(i) if (cice(i) < one) then - wet(i) = .true. ! some open ocean/lake water exists + wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif From 5d50830a0297ac609995ee7ba8ab5e9363b9fa2b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 23 Oct 2020 15:26:28 -0400 Subject: [PATCH 010/165] some compacting of code that does not change results --- physics/GFS_surface_composites.F90 | 32 +++++++++++++++--------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 30695136f..251987a4c 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -79,29 +79,29 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx) tsfco(i) = max(tisfc(i), tgice) + endif else cice(i) = zero flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif else if (cice(i) >= min_lakeice) then icy(i) = .true. islmsk(i) = 2 + if (cice(i) < one) then + wet(i) = .true. ! some open lake + tsfco(i) = max(tisfc(i), tgice) + endif else cice(i) = zero ! islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif endif else cice(i) = zero @@ -121,29 +121,29 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + tsfco(i) = max(tisfc(i), tgice) + endif else cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif else if (cice(i) >= min_lakeice) then icy(i) = .true. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + tsfco(i) = max(tisfc(i), tgice) + endif else cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif endif endif enddo From 3b9cea237db1b63f63562647e9bb46c51ae1de71 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 25 Oct 2020 21:28:19 -0400 Subject: [PATCH 011/165] Revert "some compacting of code that does not change results" This reverts commit 5d50830a0297ac609995ee7ba8ab5e9363b9fa2b. --- physics/GFS_surface_composites.F90 | 32 +++++++++++++++--------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 251987a4c..30695136f 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -79,29 +79,29 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx) tsfco(i) = max(tisfc(i), tgice) - endif else cice(i) = zero flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif else if (cice(i) >= min_lakeice) then icy(i) = .true. islmsk(i) = 2 - if (cice(i) < one) then - wet(i) = .true. ! some open lake - tsfco(i) = max(tisfc(i), tgice) - endif else cice(i) = zero ! islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif endif else cice(i) = zero @@ -121,29 +121,29 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - tsfco(i) = max(tisfc(i), tgice) - endif else cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif else if (cice(i) >= min_lakeice) then icy(i) = .true. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - tsfco(i) = max(tisfc(i), tgice) - endif else cice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif endif endif enddo From d004773c06f81b27f429358cf3c63b7549a42471 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 26 Oct 2020 21:13:25 -0400 Subject: [PATCH 012/165] some additional fixes - standalone fractional grid is still not reproducing --- physics/GFS_surface_composites.F90 | 23 ++++++++++++++++------- physics/sfc_sice.f | 30 ++++-------------------------- physics/sfc_sice.meta | 16 ---------------- 3 files changed, 20 insertions(+), 49 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 30695136f..e430765ec 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -71,6 +71,11 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx errmsg = '' errflg = 0 + ! Assign sea ice temperature to interstitial variable + do i = 1, im + tice(i) = tisfc(i) + enddo + if (frac_grid) then ! cice is ice fraction wrt water area do i=1,im frland(i) = landfrac(i) @@ -79,6 +84,14 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. + tice(i) = min(tisfc(i), tgice) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + endif + islmsk(i) = 2 else cice(i) = zero flag_cice(i) = .false. @@ -93,9 +106,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (cice(i) >= min_lakeice) then icy(i) = .true. islmsk(i) = 2 + tice(i) = min(tisfc(i), tgice) else cice(i) = zero -! islmsk(i) = 0 + islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) if (cice(i) < one) then @@ -203,7 +217,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx qss_ice(i) = qss(i) hflx_ice(i) = hflx(i) endif - slmsk(i) = islmsk(i) + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category @@ -219,11 +233,6 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx endif enddo - ! Assign sea ice temperature to interstitial variable - do i = 1, im - tice(i) = tisfc(i) - enddo - end subroutine GFS_surface_composites_pre_run end module GFS_surface_composites_pre diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index d3f7326f0..cc126931d 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -47,8 +47,7 @@ subroutine sfc_sice_run & & flag_iter, lprnt, ipr, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & frac_grid, icy, islmsk_cice, & - & min_lakeice, min_seaice, oceanfrac, & + & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & & errmsg, errflg & ) @@ -152,7 +151,6 @@ subroutine sfc_sice_run & ! --- inputs: integer, intent(in) :: im, kice, ipr logical, intent(in) :: lprnt - logical, intent(in) :: frac_grid real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & & epsm1, grav, rvrdm1, t0c, rd @@ -166,7 +164,7 @@ subroutine sfc_sice_run & real (kind=kind_phys), intent(in) :: delt, min_seaice, & & min_lakeice - logical, dimension(im), intent(in) :: flag_iter, icy + logical, dimension(im), intent(in) :: flag_iter ! --- input/outputs: real (kind=kind_phys), dimension(im), intent(inout) :: hice, & @@ -193,7 +191,6 @@ subroutine sfc_sice_run & real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin integer :: i, k - integer, dimension(im) :: islmsk_local logical :: flag(im) ! @@ -206,31 +203,12 @@ subroutine sfc_sice_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - - islmsk_local = islmsk_cice - if (frac_grid) then - do i=1,im - if (icy(i) .and. islmsk_local(i) < 2) then - if (oceanfrac(i) > zero) then - tem = min_seaice - else - tem = min_lakeice - endif - if (fice(i) > tem) then - islmsk_local(i) = 2 - tice(i) = min(tice(i), tgice) - endif - endif - enddo - endif - ! !> - Set flag for sea-ice. do i = 1, im - flag(i) = (islmsk_local(i) == 2) .and. flag_iter(i) - if (flag_iter(i) .and. islmsk_local(i) < 2) then + flag(i) = (islmsk_cice(i) == 2) .and. flag_iter(i) + if (flag_iter(i) .and. islmsk_cice(i) < 2) then hice(i) = zero fice(i) = zero endif diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 4ce931bac..67b01180f 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -425,22 +425,6 @@ kind = kind_phys intent = inout optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F [islmsk_cice] standard_name = sea_land_ice_mask_cice long_name = sea/land/ice mask cice (=0/1/2) From de54bb47609fc32785e6ecc65053545f11dc8c4e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 26 Oct 2020 22:14:16 -0400 Subject: [PATCH 013/165] some additional minor update --- physics/GFS_surface_composites.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index e430765ec..c6ac49d1c 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -71,11 +71,6 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx errmsg = '' errflg = 0 - ! Assign sea ice temperature to interstitial variable - do i = 1, im - tice(i) = tisfc(i) - enddo - if (frac_grid) then ! cice is ice fraction wrt water area do i=1,im frland(i) = landfrac(i) @@ -84,7 +79,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - tice(i) = min(tisfc(i), tgice) + tisfc(i) = min(tisfc(i), tgice) if (cplflx) then islmsk_cice(i) = 4 flag_cice(i) = .true. @@ -106,7 +101,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (cice(i) >= min_lakeice) then icy(i) = .true. islmsk(i) = 2 - tice(i) = min(tisfc(i), tgice) + tisfc(i) = min(tisfc(i), tgice) else cice(i) = zero islmsk(i) = 0 @@ -233,6 +228,11 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx endif enddo + ! Assign sea ice temperature to interstitial variable + do i = 1, im + tice(i) = tisfc(i) + enddo + end subroutine GFS_surface_composites_pre_run end module GFS_surface_composites_pre From 803ceacdc3b30a0959f444434aadc9576437faab Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 6 Nov 2020 20:20:45 -0500 Subject: [PATCH 014/165] reversing mg3 change and some other updates - yet to be tested as Hera has becom very slow --- physics/GFS_surface_composites.F90 | 63 ++++++++++++++---------- physics/GFS_surface_composites.meta | 18 +++---- physics/micro_mg3_0.F90 | 37 +++++--------- physics/sfc_sice.f | 76 +++++++++++++++-------------- physics/sfc_sice.meta | 27 ---------- 5 files changed, 100 insertions(+), 121 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index c6ac49d1c..afc134ebe 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -26,7 +26,7 @@ end subroutine GFS_surface_composites_pre_finalize !! subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & + dry, icy, lake, ocean, wet, hice, cice, zorl, zorlo, zorll, zorli, zorl_wat, & zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & @@ -42,9 +42,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx logical, intent(in ) :: frac_grid, cplflx, cplwav2atm logical, dimension(im), intent(inout) :: flag_cice logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet - real(kind=kind_phys), intent(in ) :: cimin real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac - real(kind=kind_phys), dimension(im), intent(inout) :: cice + real(kind=kind_phys), dimension(im), intent(inout) :: cice, hice real(kind=kind_phys), dimension(im), intent( out) :: frland real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd, qss, hflx @@ -60,6 +59,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -79,7 +80,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. - tisfc(i) = min(tisfc(i), tgice) + tisfc(i) = max(timin, min(tisfc(i), tgice)) if (cplflx) then islmsk_cice(i) = 4 flag_cice(i) = .true. @@ -89,6 +90,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx islmsk(i) = 2 else cice(i) = zero + hice(i) = zero flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 @@ -101,9 +103,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (cice(i) >= min_lakeice) then icy(i) = .true. islmsk(i) = 2 - tisfc(i) = min(tisfc(i), tgice) + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero + hice(i) = zero islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) @@ -112,8 +115,9 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif - else + else ! all land cice(i) = zero + hice(i) = zero endif enddo @@ -125,13 +129,16 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx dry(i) = .true. frland(i) = one cice(i) = zero + hice(i) = zero else frland(i) = zero if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then - icy(i) = .true. + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero + hice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 @@ -143,8 +150,10 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx else if (cice(i) >= min_lakeice) then icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero + hice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 endif @@ -379,7 +388,7 @@ subroutine GFS_surface_composites_post_run ( ! Local variables integer :: i, k - real(kind=kind_phys) :: txl, txi, txo, tem + real(kind=kind_phys) :: txl, txi, txo, wfrac ! Initialize CCPP error handling variables errmsg = '' @@ -392,9 +401,10 @@ subroutine GFS_surface_composites_post_run ( do i=1, im ! Three-way composites (fields from sfc_diff) - txl = landfrac(i) - txi = cice(i)*(one - txl) ! txi = ice fraction wrt whole cell - txo = max(zero, one - txl - txi) + txl = landfrac(i) ! land fraction + wfrac = one - txl ! ocean fraction + txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell + txo = max(zero, wfrac - txi) ! txo = open water fraction zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) @@ -419,11 +429,10 @@ subroutine GFS_surface_composites_post_run ( !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) if (.not. flag_cice(i) .and. islmsk(i) == 2) then - tem = one - txl - evap(i) = txl*evap_lnd(i) + tem*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + tem*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + tem*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + tem*gflx_ice(i) + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) @@ -466,14 +475,18 @@ subroutine GFS_surface_composites_post_run ( ! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! endif - if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array - tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) - hice(i) = zero - cice(i) = zero - tisfc(i) = tsfc(i) - endif +! if (.not. flag_cice(i)) then +! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array +! tisfc(i) = tice(i) +! else ! this would be over open ocean or land (no ice fraction) +! hice(i) = zero +! cice(i) = zero +! tisfc(i) = tsfc(i) +! endif +! endif + if (.not. icy(i)) then + hice(i) = zero + cice(i) = zero endif enddo @@ -565,7 +578,7 @@ subroutine GFS_surface_composites_post_run ( zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) elseif (wet(i)) then - if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 7ce84b92e..21b308357 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -140,23 +140,23 @@ type = logical intent = inout optional = F -[cice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout optional = F -[cimin] - standard_name = minimum_sea_ice_concentration - long_name = minimum sea ice concentration +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water units = frac - dimensions = () + dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout optional = F [zorl] standard_name = surface_roughness_length diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index ad5166bd3..636293b86 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -1080,7 +1080,7 @@ subroutine micro_mg_tend ( & integer i, k, n ! number of sub-steps for loops over "n" (for sedimentation) - integer nstep, mdust, nlb, nstep_def, kmin, kminp1 + integer nstep, mdust, nlb, nstep_def ! Varaibles to scale fall velocity between small and regular ice regimes. ! real(r8) :: irad, ifrac, tsfac @@ -1092,10 +1092,6 @@ subroutine micro_mg_tend ( & ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) ! ts_au_min=180.0 - real(r8), parameter :: pmin_sed = 5000.0 ! layer pressure in Pa below which - ! sedimentation calcuation is done -! integer, parameter :: nstep_fac=10 ! factor for definng nstep_def - integer, parameter :: nstep_fac=5 ! factor for definng nstep_def !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -1105,7 +1101,8 @@ subroutine micro_mg_tend ( & !> - Assign variable deltat to deltatin deltat = deltatin oneodt = one / deltat - nstep_def = max(1, nint(deltat/nstep_fac)) +! nstep_def = max(1, nint(deltat/20)) + nstep_def = max(1, nint(deltat/5)) ! tsfac = log(ts_au/ts_au_min) * qiinv !> - Copies of input concentrations that may be changed internally. @@ -3415,19 +3412,11 @@ subroutine micro_mg_tend ( & tx1 = tx2 * deltat tx3 = tx2 / g - kmin = 1 - do k=2,nlev-1 - if (p(i,k) < pmin_sed) then - kmin = k - endif - enddo - kminp1 = kmin + 1 - do n = 1,nstep ! top of model - k = kmin + k = 1 ! add fallout terms to microphysical tendencies @@ -3448,7 +3437,7 @@ subroutine micro_mg_tend ( & iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - do k = kminp1,nlev + do k = 2,nlev ! for cloud liquid and ice, if cloud fraction increases with height ! then add flux from above to both vapor and cloud water of current level @@ -3517,7 +3506,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = kmin + k = 1 tx5 = dumc(i,k) tx7 = pdel_inv(i,k) * tx1 @@ -3536,7 +3525,7 @@ subroutine micro_mg_tend ( & faloutnc(k) = fnc(i,k) * dumnc(i,k) lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 - do k = kminp1,nlev + do k = 2,nlev if (lcldm(i,k-1) > mincld) then dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) @@ -3600,7 +3589,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = kmin + k = 1 ! add fallout terms to microphysical tendencies @@ -3621,7 +3610,7 @@ subroutine micro_mg_tend ( & rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 - do k = kminp1,nlev + do k = 2,nlev tx5 = dumr(i,k) tx7 = pdel_inv(i,k) * tx1 @@ -3662,7 +3651,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = kmin + k = 1 ! add fallout terms to microphysical tendencies @@ -3683,7 +3672,7 @@ subroutine micro_mg_tend ( & sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 - do k = kminp1,nlev + do k = 2,nlev tx5 = dums(i,k) @@ -3729,7 +3718,7 @@ subroutine micro_mg_tend ( & do n = 1,nstep ! top of model - k = kmin + k = 1 ! add fallout terms to microphysical tendencies @@ -3750,7 +3739,7 @@ subroutine micro_mg_tend ( & gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - do k = kminp1,nlev + do k = 2,nlev tx5 = dumg(i,k) tx7 = pdel_inv(i,k) * tx1 diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index cc126931d..0cbf84353 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -47,7 +47,8 @@ subroutine sfc_sice_run & & flag_iter, lprnt, ipr, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & + & islmsk_cice, & +! & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & & errmsg, errflg & ) @@ -70,21 +71,21 @@ subroutine sfc_sice_run & ! subprogram called: ice3lay. ! ! ! !> program history log: -!!- 2005 -- xingren wu created from original progtm and added -!! two-layer ice model -!!- 200x -- sarah lu added flag_iter -!!- oct 2006 -- h. wei added cmm and chh to output +!!- 2005 -- xingren wu created from original progtm and added +!! two-layer ice model +!!- 200x -- sarah lu added flag_iter +!!- oct 2006 -- h. wei added cmm and chh to output !!- 2007 -- x. wu modified for mom4 coupling (i.e. cpldice) !! (not used anymore) -!!- 2007 -- s. moorthi micellaneous changes -!!- may 2009 -- y.-t. hou modified to include surface emissivity -!! effect on lw radiation. replaced the confusing +!!- 2007 -- s. moorthi micellaneous changes +!!- may 2009 -- y.-t. hou modified to include surface emissivity +!! effect on lw radiation. replaced the confusing !! slrad with sfc net sw sfcnsw (dn-up). reformatted -!! the code and add program documentation block. -!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and -!! further optimized -!!- jan 2015 -- x. wu change "cimin = 0.15" for both -!! uncoupled and coupled case +!! the code and add program documentation block. +!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and +!! further optimized +!!- jan 2015 -- x. wu change "cimin = 0.15" for both +!! uncoupled and coupled case ! ! ! ! ! ==================== defination of variables ==================== ! @@ -157,12 +158,14 @@ subroutine sfc_sice_run & real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind, oceanfrac + & prsl1, prslki, prsik1, prslk1, wind +! & prsl1, prslki, prsik1, prslk1, wind, oceanfrac ! integer, dimension(im), intent(in) :: islimsk integer, dimension(im), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt, min_seaice, & - & min_lakeice + real (kind=kind_phys), intent(in) :: delt +! real (kind=kind_phys), intent(in) :: delt, min_seaice, & +! & min_lakeice logical, dimension(im), intent(in) :: flag_iter @@ -188,7 +191,8 @@ subroutine sfc_sice_run & real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw +! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin integer :: i, k @@ -208,10 +212,10 @@ subroutine sfc_sice_run & do i = 1, im flag(i) = (islmsk_cice(i) == 2) .and. flag_iter(i) - if (flag_iter(i) .and. islmsk_cice(i) < 2) then - hice(i) = zero - fice(i) = zero - endif +! if (flag_iter(i) .and. islmsk_cice(i) < 2) then +! hice(i) = zero +! fice(i) = zero +! endif enddo do i = 1, im @@ -241,11 +245,11 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then - if (oceanfrac(i) > zero) then - cimin = min_seaice - else - cimin = min_lakeice - endif +! if (oceanfrac(i) > zero) then +! cimin = min_seaice +! else +! cimin = min_lakeice +! endif ! psurf(i) = 1000.0 * ps(i) ! ps1(i) = 1000.0 * prsl1(i) @@ -264,13 +268,13 @@ subroutine sfc_sice_run & qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) q0 = min(qs1, q0) - if (fice(i) < cimin) then - print *,'warning: ice fraction is low:', fice(i) - fice(i) = cimin - tice(i) = tgice - tskin(i)= tgice - print *,'fix ice fraction: reset it to:', fice(i) - endif +! if (fice(i) < cimin) then +! print *,'warning: ice fraction is low:', fice(i) +! fice(i) = cimin +! tice(i) = tgice +! tskin(i)= tgice +! print *,'fix ice fraction: reset it to:', fice(i) +! endif ffw(i) = one - fice(i) qssi = fpvs(tice(i)) @@ -350,7 +354,7 @@ subroutine sfc_sice_run & !> - Call the three-layer thermodynamics sea ice model ice3lay(). call ice3lay ! --- inputs: ! - & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! + & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! & lprnt, ipr, ! --- outputs: ! & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! @@ -359,14 +363,14 @@ subroutine sfc_sice_run & if (flag(i)) then if (tice(i) < timin) then print *,'warning: snow/ice temperature is too low:',tice(i) - &,' i=',i + &, ' i=',i tice(i) = timin print *,'fix snow/ice temperature: reset it to:',tice(i) endif if (stsice(i,1) < timin) then print *,'warning: layer 1 ice temp is too low:',stsice(i,1) - &,' i=',i + &, ' i=',i stsice(i,1) = timin print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) endif diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 67b01180f..469a967fc 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -433,33 +433,6 @@ type = integer intent = in optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 2cf345e87371f31211702e378b449b8ec1927f82 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Mon, 9 Nov 2020 16:47:13 -0600 Subject: [PATCH 015/165] Properly initialize wet deposition work array to prevent floating point runtime errors. --- physics/samfaerosols.F | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/physics/samfaerosols.F b/physics/samfaerosols.F index fea4b5ead..9d7f91e99 100644 --- a/physics/samfaerosols.F +++ b/physics/samfaerosols.F @@ -77,6 +77,7 @@ subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, ecdo2 = zero ecko2 = zero qaero = zero + wet_dep = zero c -- set work arrays @@ -477,6 +478,7 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, !ecdo2 = zero ecko2 = zero qaero = zero + wet_dep = zero c -- set work arrays @@ -810,4 +812,4 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, return end subroutine samfshalcnv_aerosols - end module samfcnv_aerosols \ No newline at end of file + end module samfcnv_aerosols From f3c990ee43ef55c5556046021335f3da0d2db46b Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Mon, 9 Nov 2020 16:58:45 -0600 Subject: [PATCH 016/165] Properly initialize work arrays in SAMF deep convection scheme. --- physics/samfdeepcnv.f | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 1b71e011e..c58a0de4a 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -326,12 +326,20 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cina(i) = 0. pwavo(i)= 0. pwevo(i)= 0. + xmb(i) = 0. xpwav(i)= 0. xpwev(i)= 0. vshear(i) = 0. rainevap(i) = 0. gdx(i) = sqrt(garea(i)) enddo + + do k=1,km + do i=1,im + xlamud(i,k) = 0. + xlamue(i,k) = 0. + enddo + enddo ! if (hwrf_samfdeep) then do i=1,im From e5818a3b486920e2c4564f0f940ad245989287a7 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Mon, 9 Nov 2020 17:13:15 -0600 Subject: [PATCH 017/165] Properly initialize work arrays in SAMF shallow convection scheme. --- physics/samfshalcnv.f | 2 ++ 1 file changed, 2 insertions(+) diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index ce6ae62c4..1ebbb6fc8 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -251,6 +251,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cina(i) = 0. vshear(i) = 0. gdx(i) = sqrt(garea(i)) + xmb(i) = 0. scaldfunc(i)=-1.0 ! wang initialized sigmagfm(i)=-1.0 enddo @@ -275,6 +276,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & cina(i) = 0. vshear(i) = 0. gdx(i) = sqrt(garea(i)) + xmb(i) = 0. enddo endif !! From a0daf0c3bfcadd575eb03b94016f5a94556e758f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 12 Nov 2020 15:52:41 +0000 Subject: [PATCH 018/165] some minor update to GFS_surface_composites.F90 - still has issue in restart reproducing with frac_grid=.true. --- physics/GFS_surface_composites.F90 | 20 +++++++++++--------- physics/sfc_sice.f | 2 +- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index afc134ebe..89279e29d 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -118,6 +118,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx else ! all land cice(i) = zero hice(i) = zero + islmsk_cice(i) = 1 + islmsk(i) = 1 endif enddo @@ -185,7 +187,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water - uustar_wat(i) = uustar(i) +! uustar_wat(i) = uustar(i) zorl_wat(i) = zorlo(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) @@ -193,9 +195,9 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! snowd_wat(i) = snowd(i) weasd_wat(i) = zero snowd_wat(i) = zero - semis_wat(i) = 0.984d0 - qss_wat(i) = qss(i) - hflx_wat(i) = hflx(i) + semis_wat(i) = 0.984_kind_phys +! qss_wat(i) = qss(i) +! hflx_wat(i) = hflx(i) endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) @@ -205,8 +207,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx tsurf_lnd(i) = tsfcl(i) snowd_lnd(i) = snowd(i) semis_lnd(i) = semis_rad(i) - qss_lnd(i) = qss(i) - hflx_lnd(i) = hflx(i) +! qss_lnd(i) = qss(i) +! hflx_lnd(i) = hflx(i) end if if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) @@ -218,8 +220,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ep1d_ice(i) = zero gflx_ice(i) = zero semis_ice(i) = 0.95_kind_phys - qss_ice(i) = qss(i) - hflx_ice(i) = hflx(i) +! qss_ice(i) = qss(i) +! hflx_ice(i) = hflx(i) endif if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo @@ -404,7 +406,7 @@ subroutine GFS_surface_composites_post_run ( txl = landfrac(i) ! land fraction wfrac = one - txl ! ocean fraction txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell - txo = max(zero, wfrac - txi) ! txo = open water fraction + txo = max(zero, wfrac-txi) ! txo = open water fraction zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 0cbf84353..48dcaf0f5 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -46,7 +46,7 @@ subroutine sfc_sice_run & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & & flag_iter, lprnt, ipr, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: - & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! + & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & & islmsk_cice, & ! & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & & errmsg, errflg From 0a69d110f27ad9ec9b4660e7604aa30b679301db Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 14 Nov 2020 02:05:13 +0000 Subject: [PATCH 019/165] some update to GFS_surface_generic.F90 - restart run with frac_grid=.truereproduces continuous run in REPRO mode --- physics/GFS_surface_generic.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 519336860..69083c91c 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -368,20 +368,20 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt do i=1,im hflxq(i) = hflx(i) evapq(i) = evap(i) - hffac(i) = 1.0 - hefac(i) = 1.0 + hffac(i) = one + hefac(i) = one enddo if (lheatstrg) then do i=1,im - tem = 0.01 * zorl(i) ! change unit from cm to m + tem = 0.01_kind_phys * zorl(i) ! change unit from cm to m tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(u10m(i)**2+v10m(i)**2) + hffac(i) = z0fac * min(max(tem1, zero), one) + tem = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) + tem2 = one - min(max(tem1, zero), one) hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + e0fac * hffac(i) - hffac(i) = 1. + hffac(i) + hefac(i) = one + e0fac * hffac(i) + hffac(i) = one + hffac(i) hflxq(i) = hflx(i) / hffac(i) evapq(i) = evap(i) / hefac(i) enddo From 64028eb511878ae49a9e3d0c5eb15953ace9c47b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 16 Nov 2020 00:02:30 +0000 Subject: [PATCH 020/165] minor update to gcycle --- physics/gcycle.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 8b3555826..894264f05 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -9,7 +9,7 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) ! ! USE MACHINE, only: kind_phys - USE PHYSCONS, only: PI => con_PI + USE PHYSCONS, only: PI => con_PI, con_tice USE GFS_typedefs, only: GFS_control_type, GFS_grid_type, & GFS_sfcprop_type, GFS_cldprop_type implicit none @@ -217,8 +217,11 @@ SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) ! + dt_warm - Sfcprop(nb)%dt_cool(ix) ! endif else - Sfcprop(nb)%tsfc(ix) = TSFFCS (len) - Sfcprop(nb)%tsfco(ix) = TSFFCS (len) + Sfcprop(nb)%tsfc(ix) = TSFFCS (len) + Sfcprop(nb)%tsfco(ix) = TSFFCS (len) + if (slifcs(len) > 1.9_kind_phys) then + Sfcprop(nb)%tsfco(ix) = con_tice + endif endif Sfcprop(nb)%weasd (ix) = SNOFCS (len) Sfcprop(nb)%zorll (ix) = ZORFCS (len) From f5c496bbb2c532a81d540d320f42cbb8dca3a635 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 29 Nov 2020 01:52:22 +0000 Subject: [PATCH 021/165] updating rascnv.meta --- physics/rascnv.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rascnv.meta b/physics/rascnv.meta index f0ab36f19..cac328186 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -422,7 +422,7 @@ standard_name = convective_transportable_tracers long_name = array to contain cloud water and other convective trans. tracers units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,tracer_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) type = real kind = kind_phys intent = inout From aa2b98be6b22c5fdbf4782baf5269aad26168a3e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 5 Dec 2020 00:27:14 +0000 Subject: [PATCH 022/165] some minor update to surface_composite --- physics/GFS_surface_composites.F90 | 32 ++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 89279e29d..3202d2a2e 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -205,7 +205,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx zorl_lnd(i) = zorll(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) - snowd_lnd(i) = snowd(i) +! snowd_lnd(i) = snowd(i) / frland(i) semis_lnd(i) = semis_rad(i) ! qss_lnd(i) = qss(i) ! hflx_lnd(i) = hflx(i) @@ -216,7 +216,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx zorl_ice(i) = zorli(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) - snowd_ice(i) = snowd(i) +! snowd_ice(i) = snowd(i) / cice(i) ep1d_ice(i) = zero gflx_ice(i) = zero semis_ice(i) = 0.95_kind_phys @@ -238,6 +238,33 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx lake(i) = .false. endif enddo +! + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + snowd_lnd(i) = snowd(i) / (frland(i) + cice(i)) + snowd_ice(i) = snowd_lnd(i) + else + snowd_lnd(i) = snowd(i) / frland(i) + snowd_ice(i) = zero + endif + elseif (icy(i)) then + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) / cice(i) + endif + enddo + else + do i=1,im + if (dry(i)) then + snowd_lnd(i) = snowd(i) + snowd_ice(i) = zero + elseif (icy(i)) then + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) / cice(i) + endif + enddo + endif ! Assign sea ice temperature to interstitial variable do i = 1, im @@ -590,6 +617,7 @@ subroutine GFS_surface_composites_post_run ( qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) + snowd(i) = txi * snowd_ice(i) else evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) From d4ececd7b35dc109b16a5db85806efde26e437ea Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 8 Dec 2020 20:17:40 -0500 Subject: [PATCH 023/165] some updates to sfc codes --- physics/GFS_surface_composites.F90 | 33 ++++++++++----------------- physics/GFS_surface_generic.F90 | 4 +--- physics/GFS_surface_generic.meta | 36 ------------------------------ 3 files changed, 13 insertions(+), 60 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 3202d2a2e..98d6b3b80 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -544,7 +544,6 @@ subroutine GFS_surface_composites_post_run ( ep1d(i) = ep1d_lnd(i) weasd(i) = weasd_lnd(i) snowd(i) = snowd_lnd(i) - !tprcp(i) = tprcp_lnd(i) evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) @@ -572,7 +571,6 @@ subroutine GFS_surface_composites_post_run ( ep1d(i) = ep1d_wat(i) weasd(i) = weasd_wat(i) snowd(i) = snowd_wat(i) - !tprcp(i) = tprcp_wat(i) evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) @@ -596,47 +594,40 @@ subroutine GFS_surface_composites_post_run ( ep1d(i) = ep1d_ice(i) weasd(i) = weasd_ice(i) snowd(i) = snowd_ice(i) - !tprcp(i) = cice(i)*tprcp_ice(i) + (one-cice(i))*tprcp_wat(i) qss(i) = qss_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) - tisfc(i) = tice(i) - if (.not. flag_cice(i)) then -! tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) - tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) - elseif (wet(i)) then - if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) +! + if (flag_cice(i)) then + if (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) - stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + stress(i) = txi *stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) snowd(i) = txi * snowd_ice(i) - else - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - tsfc(i) = tsfc_wat(i) - stress(i) = stress_wat(i) - qss(i) = qss_wat(i) - ep1d(i) = ep1d_wat(i) - zorl(i) = zorl_wat(i) endif + elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array + zorl(i) = cice(i)*zorl_ice(i) + (one-cice(i))*zorl_wat(i) endif +! if (wet(i)) then tsfco(i) = tsfc_wat(i) else tsfco(i) = tsfc(i) endif - tsfcl(i) = tsfc(i) + tsfcl(i) = tsfc(i) + do k=1,kice ! store tiice in stc to reduce output in the nonfrac grid case stc(i,k) = tiice(i,k) - end do + enddo endif zorll(i) = zorl_lnd(i) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index c308f9d6c..bdcb086b4 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -30,7 +30,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, tisfc, tsfco, fice, hice, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) use surface_perturbation, only: cdfnor @@ -73,8 +73,6 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl logical, dimension(im), intent(inout) :: flag_cice integer, dimension(im), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(im), intent(in) :: & - tisfc, tsfco, fice, hice real(kind=kind_phys), dimension(im), intent(out) :: wind real(kind=kind_phys), dimension(im), intent(in ) :: u1, v1 diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 68713ab19..52a44fea7 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -379,42 +379,6 @@ kind = kind_phys intent = in optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea-ice surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fice] - standard_name = sea_ice_concentration - long_name = sea-ice concentration [0,1] - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea-ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level From 217b91ae0c7e05265c731ff4769cfa2d4efb0bc5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 10 Dec 2020 19:30:44 -0500 Subject: [PATCH 024/165] changing > to >= --- physics/GFS_surface_composites.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 98d6b3b80..952a8019e 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -602,13 +602,13 @@ subroutine GFS_surface_composites_post_run ( tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) ! if (flag_cice(i)) then - if (wet(i) .and. cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) - stress(i) = txi *stress_ice(i) + txo * stress_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) From 5a8362705303dbcf6b29bd9f0cfc0ba99861a885 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 22 Dec 2020 10:17:31 -0500 Subject: [PATCH 025/165] some minor updates to surface_composite logic and consistent emissivity --- physics/GFS_surface_composites.F90 | 23 ++++++++++++++++++----- physics/radiation_surface.f | 4 ++-- 2 files changed, 20 insertions(+), 7 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 952a8019e..82cbd2211 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -86,6 +86,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx flag_cice(i) = .true. else islmsk_cice(i) = 2 + flag_cice(i) = .false. endif islmsk(i) = 2 else @@ -101,15 +102,16 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx endif else if (cice(i) >= min_lakeice) then - icy(i) = .true. + icy(i) = .true. islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero hice(i) = zero islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -138,6 +140,14 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (cice(i) >= min_seaice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 else cice(i) = zero hice(i) = zero @@ -153,13 +163,14 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (cice(i) >= min_lakeice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 else cice(i) = zero hice(i) = zero - flag_cice(i) = .false. islmsk(i) = 0 endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -195,7 +206,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! snowd_wat(i) = snowd(i) weasd_wat(i) = zero snowd_wat(i) = zero - semis_wat(i) = 0.984_kind_phys + semis_wat(i) = 0.97_kind_phys +! semis_wat(i) = 0.984_kind_phys ! qss_wat(i) = qss(i) ! hflx_wat(i) = hflx(i) endif @@ -219,7 +231,8 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! snowd_ice(i) = snowd(i) / cice(i) ep1d_ice(i) = zero gflx_ice(i) = zero - semis_ice(i) = 0.95_kind_phys + semis_ice(i) = 0.96_kind_phys +! semis_ice(i) = 0.95_kind_phys ! qss_ice(i) = qss(i) ! hflx_ice(i) = hflx(i) endif diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index f0cbdd18a..9cbeb733b 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -617,9 +617,9 @@ subroutine setalb & ab1bm = min(0.99, alnsf(i)*rfcs) ab2bm = min(0.99, alvsf(i)*rfcs) sfcalb(i,1) = ab1bm *flnd + asenb*fsea + asnnb*fsno - sfcalb(i,2) = alnwf(i) *flnd + asend*fsea + asnnd*fsno + sfcalb(i,2) = alnwf(i)*flnd + asend*fsea + asnnd*fsno sfcalb(i,3) = ab2bm *flnd + asevb*fsea + asnvb*fsno - sfcalb(i,4) = alvwf(i) *flnd + asevd*fsea + asnvd*fsno + sfcalb(i,4) = alvwf(i)*flnd + asevd*fsea + asnvd*fsno enddo ! end_do_i_loop From 44a3c5c20a8d775d3c28e5b72c8aff27d2329fc6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 22 Dec 2020 13:09:31 -0500 Subject: [PATCH 026/165] after merging with ccpp-physics master on Dec 22 --- physics/rte-rrtmgp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 33c8a984c..566bee9cd 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 33c8a984c17cf41be5d4c2928242e1b4239bfc40 +Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d From 340ee5c3e5f31faedeb833d52ae3ae992115fc4d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 22 Dec 2020 19:47:38 -0500 Subject: [PATCH 027/165] fixing an error in converting nsst code from IPD physics driver to ccpp --- physics/sfc_nst.f | 10 +++++----- physics/sfc_nst.meta | 8 ++++---- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 9e6a1c0cc..6138d6f37 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -668,7 +668,7 @@ end subroutine sfc_nst_pre_finalize !> \section NSST_general_pre_algorithm General Algorithm !! @{ subroutine sfc_nst_pre_run - & (im, wet, tsfc_wat, tsurf_wat, tseal, xt, xz, dt_cool, + & (im, wet, tsfco, tsurf_wat, tseal, xt, xz, dt_cool, & z_c, tref, cplflx, oceanfrac, nthreads, errmsg, errflg) use machine , only : kind_phys @@ -682,7 +682,7 @@ subroutine sfc_nst_pre_run integer, intent(in) :: im, nthreads logical, dimension(im), intent(in) :: wet real (kind=kind_phys), dimension(im), intent(in) :: - & tsfc_wat, xt, xz, dt_cool, z_c, oceanfrac + & tsfco, xt, xz, dt_cool, z_c, oceanfrac logical, intent(in) :: cplflx ! --- input/outputs: @@ -711,8 +711,8 @@ subroutine sfc_nst_pre_run ! tem = (oro(i)-oro_uf(i)) * rlapse ! DH* 20190927 simplyfing this code because tem is zero !tem = zero - !tseal(i) = tsfc_wat(i) + tem - tseal(i) = tsfc_wat(i) + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) !tsurf_wat(i) = tsurf_wat(i) + tem ! *DH endif @@ -727,7 +727,7 @@ subroutine sfc_nst_pre_run do i=1,im if (wet(i) .and. oceanfrac(i) > zero) then ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf - tref(i) = tsfc_wat(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile + tref(i) = tsfco(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update ! tseal(i) = tsfc_wat(i) if (abs(xz(i)) > zero) then diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 2c32ca106..2b99365ec 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -671,14 +671,14 @@ type = logical intent = in optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature units = K dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = in + intent = inout optional = F [tsurf_wat] standard_name = surface_skin_temperature_after_iteration_over_ocean From 584faeaf5e3eb20a9ca47654d3be15ef0f66e90c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 10 Jan 2021 19:12:13 -0500 Subject: [PATCH 028/165] printing rsics in sfcsub --- physics/sfcsub.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 1a1a8eefa..283095f36 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -4811,8 +4811,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & 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) + write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics + 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.3) ! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl ! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets endif From 1f53483bcffb402d04c3f57712c34e3149800fb5 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 14 Jan 2021 00:56:22 +0000 Subject: [PATCH 029/165] some update to sfcsub.F --- physics/sfcsub.F | 104 ++++++++++++++++++++++++++++------------------- 1 file changed, 62 insertions(+), 42 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 283095f36..8c2d81c45 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -532,6 +532,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer kpd7, kpd9 ! logical icefl1(len), icefl2(len) +! + real (kind=kind_io8), allocatable, dimension(:) :: & + & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & + & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & + & vmnfcsd, vmxfcsd, slpfcsd, absfcsd + real (kind=kind_io8), allocatable, dimension(:,:) :: & + & smcfcsd, stcfcsd, albfcsd ! ! input and output surface fields (bges) file names ! @@ -2202,37 +2209,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! if (mondif) then + allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), & + & zorfcsd(len), slifcsd(len), aisfcsd(len), & + & cnpfcsd(len), vegfcsd(len), vetfcsd(len), & + & sotfcsd(len), sihfcsd(len), sicfcsd(len), & + & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & + & absfcsd(len)) + allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & + & albfcsd(len,4)) 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) + tsffcsd(i) = tsfanl(i) - tsffcs(i) + snofcsd(i) = snoanl(i) - snofcs(i) + tg3fcsd(i) = tg3anl(i) - tg3fcs(i) + zorfcsd(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) + slifcsd(i) = slianl(i) - slifcs(i) + aisfcsd(i) = aisanl(i) - aisfcs(i) + cnpfcsd(i) = cnpanl(i) - cnpfcs(i) + vegfcsd(i) = veganl(i) - vegfcs(i) + vetfcsd(i) = vetanl(i) - vetfcs(i) + sotfcsd(i) = sotanl(i) - sotfcs(i) !clu [+2l] add sih, sic - sihfcs(i) = sihanl(i) - sihfcs(i) - sicfcs(i) = sicanl(i) - sicfcs(i) + sihfcsd(i) = sihanl(i) - sihfcs(i) + sicfcsd(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) + vmnfcsd(i) = vmnanl(i) - vmnfcs(i) + vmxfcsd(i) = vmxanl(i) - vmxfcs(i) + slpfcsd(i) = slpanl(i) - slpfcs(i) + absfcsd(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) + smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcsd(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) + albfcsd(i,j) = albanl(i,j) - albfcs(i,j) enddo enddo ! @@ -2243,40 +2258,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & 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('tsfdif', tsffcsd,slianl,snoanl,len) + call monitr('albdif', albfcsd,slianl,snoanl,len) + call monitr('albdif1',albfcsd,slianl,snoanl,len) + call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len) + call monitr('aisdif', aisfcsd,slianl,snoanl,len) + call monitr('snodif', snofcsd,slianl,snoanl,len) do k=1,lsoil - call monitr(message('smcanl',k),smcfcs(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcfcs(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len) enddo - call monitr('tg3dif',tg3fcs,slianl,snoanl,len) - call monitr('zordif',zorfcs,slianl,snoanl,len) + call monitr('tg3dif',tg3fcsd,slianl,snoanl,len) + call monitr('zordif',zorfcsd,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('slidif',slifcsd,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) + call monitr('cnpdif',cnpfcsd,slianl,snoanl,len) + call monitr('vegdif',vegfcsd,slianl,snoanl,len) + call monitr('vetdif',vetfcsd,slianl,snoanl,len) + call monitr('sotdif',sotfcsd,slianl,snoanl,len) !cwu [+2l] add sih, sic - call monitr('sihdif',sihfcs,slianl,snoanl,len) - call monitr('sicdif',sicfcs,slianl,snoanl,len) + call monitr('sihdif',sihfcsd,slianl,snoanl,len) + call monitr('sicdif',sicfcsd,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) + call monitr('vmndif',vmnfcsd,slianl,snoanl,len) + call monitr('vmxdif',vmxfcsd,slianl,snoanl,len) + call monitr('slpdif',slpfcsd,slianl,snoanl,len) + call monitr('absdif',absfcsd,slianl,snoanl,len) endif + deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & + & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & + & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & + & absfcsd) + deallocate (smcfcsd, stcfcsd, albfcsd) endif ! ! From 930ffab4b66092c8a3c2aff9f8f08b3007e6c9b3 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 17 Feb 2021 20:10:57 -0500 Subject: [PATCH 030/165] some updates to RAS --- physics/rascnv.F90 | 169 ++++++++++++++++++++++---------------------- physics/rascnv.meta | 2 +- 2 files changed, 87 insertions(+), 84 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 1c311e4cf..34b3031f1 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -8,7 +8,7 @@ module rascnv implicit none public :: rascnv_init, rascnv_run, rascnv_finalize private - logical :: is_initialized = .False. + logical, save :: is_initialized = .False. ! integer, parameter :: kp = kind_phys integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s @@ -34,17 +34,20 @@ module rascnv &, facmb = 0.01_kp & ! conversion factor from Pa to hPa (or mb) &, cmb2pa = 100.0_kp ! Conversion from hPa to Pa ! - real(kind=kind_phys), parameter :: frac=0.5_kp, crtmsf=0.0_kp & - &, rhfacs=0.75_kp, rhfacl=0.75_kp & - &, face=5.0_kp, delx=10000.0_kp& - &, ddfac=face*delx*0.001_kp & - &, max_neg_bouy=0.15_kp & -! &, max_neg_bouy=pt25_kp & - &, testmb=0.1_kp, testmbi=one/testmb & - &, dpd=0.5_kp, rknob=1.0_kp, eknob=1.0_kp +! real (kind=kind_phys), parameter :: frac=0.5_kp, crtmsf=0.0_kp & + real (kind=kind_phys), parameter :: frac=0.1_kp, crtmsf=0.0_kp & + &, tfrac_max=0.15_kp & + &, rhfacs=0.75_kp, rhfacl=0.75_kp & + &, face=5.0_kp, delx=10000.0_kp & + &, ddfac=face*delx*0.001_kp & + &, max_neg_bouy=0.15_kp & +! &, max_neg_bouy=pt25_kp & + &, testmb=0.1_kp, testmbi=one/testmb & + &, dpd=0.5_kp, rknob=1.0_kp, eknob=1.0_kp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - logical, parameter :: do_aw=.true., cumfrc=.true. & +! logical, parameter :: aw_scal=.false., cumfrc=.true. & + logical, parameter :: aw_scal=.true., cumfrc=.true. & &, updret=.false., vsmooth=.false. & &, wrkfun=.false., crtfun=.true. & &, calkbl=.true., botop=.true., revap=.true. & @@ -67,24 +70,24 @@ module rascnv ! ! For Tilting Angle Specification ! - real(kind=kind_phys) REFP(6), REFR(6), TLAC(8), PLAC(8), TLBPL(7) & - &, drdp(5) + real(kind=kind_phys), save :: REFP(6), REFR(6), TLAC(8), PLAC(8), & + TLBPL(7), drdp(5) ! DATA PLAC/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0/ DATA TLAC/ 35.0, 25.0, 20.0, 17.5, 15.0, 12.5, 10.0, 7.5/ DATA REFP/500.0, 300.0, 250.0, 200.0, 150.0, 100.0/ DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ ! - real(kind=kind_phys) AC(16), AD(16) + real(kind=kind_phys), save :: AC(16), AD(16) ! integer, parameter :: nqrp=500001 - real(kind=kind_phys) C1XQRP, C2XQRP, TBQRP(NQRP), TBQRA(NQRP) & - &, TBQRB(NQRP) + real(kind=kind_phys), save :: C1XQRP, C2XQRP, TBQRP(NQRP), & + TBQRA(NQRP), TBQRB(NQRP) ! integer, parameter :: nvtp=10001 - real(kind=kind_phys) C1XVTP, C2XVTP, TBVTP(NVTP) + real(kind=kind_phys), save :: C1XVTP, C2XVTP, TBVTP(NVTP) ! - real(kind=kind_phys) afc, facdt, & + real(kind=kind_phys), save :: afc, facdt, & grav, cp, alhl, alhf, rgas, rkap, nu, pi, & t0c, rv, cvap, cliq, csol, ttp, eps, epsm1,& ! @@ -118,12 +121,13 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & con_g, con_cp, con_rd, con_rv, con_hvap, & con_hfus, con_fvirt, con_t0c, con_cvap, con_cliq, & con_csol, con_ttp, con_eps, con_epsm1 + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! real(kind=kind_phys), parameter :: actp=1.7_kp, facm=1.00_kp ! - real(kind=kind_phys) PH(15), A(15) + real(kind=kind_phys) :: PH(15), A(15) ! DATA PH/150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0 & &, 550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0/ @@ -134,8 +138,6 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & ! real(kind=kind_phys) tem, actop, tem1, tem2 integer i, l - logical first - data first/.true./ ! ! Initialize CCPP error handling variables errmsg = '' @@ -169,6 +171,12 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 ! AFC = -(1.01097e-4_kp*DT)*(3600.0_kp/DT)**0.57777778_kp +! + if (fix_ncld_hr) then + facdt = delt_c / dt + else + facdt = one / 3600.0_kp + endif ! grav = con_g ; cp = con_cp ; alhl = con_hvap alhf = con_hfus ; rgas = con_rd @@ -186,9 +194,9 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & picon = half*pi*onebg ; zfac = 0.28888889e-4_kp * ONEBG testmboalhl = testmb/alhl ! - rvi = one/rv ; facw=CVAP-CLIQ - faci = CVAP-CSOL ; hsub=alhl+alhf - tmix = TTP-20.0_kp ; DEN=one/(TTP-TMIX) + rvi = one / rv ; facw = CVAP - CLIQ + faci = CVAP - CSOL ; hsub = alhl + alhf + tmix = TTP - 20.0_kp ; DEN = one / (TTP-TMIX) ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & @@ -286,7 +294,7 @@ end subroutine rascnv_finalize !! \section arg_table_rascnv_run Argument Table !! \htmlinclude rascnv_run.html !! - subroutine rascnv_run(IM, k, ntr, dt, dtf & + subroutine rascnv_run(IM, k, ntr, dt, dtf & &, ccwf, area, dxmin, dxinv & &, psauras, prauras, wminras, dlqf, flipv & &, me, rannum, nrcm, mp_phys, mp_phys_mg & @@ -329,10 +337,12 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & &, psauras(2), prauras(2) & &, wminras(2), dlqf(2) ! - real(kind=kind_phys), dimension(im,k) :: tin, qin, uin, vin & - &, prsl, prslk, phil real(kind=kind_phys), dimension(im,k+1) :: prsi, prsik, phii - real(kind=kind_phys), dimension(im,k) :: ud_mf, dd_mf, dt_mf & + + real(kind=kind_phys), dimension(im,k) :: tin, qin, uin, vin & + &, prsl, prslk, phil & + + &, ud_mf, dd_mf, dt_mf & &, rhc, qlcn, qicn, w_upi & &, cnv_mfd & &, cnv_dqldt, clcn & @@ -344,7 +354,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & real(kind=kind_phys) ccin(im,k,ntr+2) real(kind=kind_phys) trcmin(ntr+2) - real(kind=kind_phys) DT, dtf, qw0, qi0 + real(kind=kind_phys) DT, dtf ! ! Added for aerosol scavenging for GOCART ! @@ -380,13 +390,13 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & &, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib & &, kblmn, ksfc, ncrnd - real(kind=kind_phys) sgcs(k,im) + real(kind=kind_phys) sgcs(k) ! ! Scavenging related parameters ! real fscav_(ntr+2) ! Fraction scavenged per km ! - fscav_ = zero ! By default no scavenging + fscav_ = zero ! By default no scavenging if (ntr > 0) then do i=1,ntr fscav_(i) = fscav(i) @@ -425,7 +435,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & endif ! !!!!! initialization for microphysics ACheng - if(mp_phys == 10) then + if(mp_phys == mp_phys_mg) then do l=1,K do i=1,im QLCN(i,l) = zero @@ -482,11 +492,12 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & KFMAX = KRMAX kblmx = 1 kblmn = 1 + sgcs(k) = one DO L=1,KM1 ll = l if (flipv) ll = kp1 -l ! Input variables are bottom to top! SGC = prsl(ipt,ll) * tem - sgcs(l,ipt) = sgc + sgcs(l) = sgc IF (SGC <= 0.050_kp) KRMIN = L ! IF (SGC <= 0.700_kp) KRMAX = L ! IF (SGC <= 0.800_kp) KRMAX = L @@ -500,6 +511,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ENDDO krmin = max(krmin,2) +! if (kdt == 1 .and. ipt == 1) write(0,*)' kblmn=',kblmn,kblmx ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 @@ -510,10 +522,8 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/360) + 0.50001 ! & + 0.50001 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * min(1.0,DTF/360) + 0.1 - facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = one / 3600.0_kp endif NCRND = min(nrcm,max(NCRND, 1)) ! @@ -779,6 +789,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! IB = IC(NC) ! cloud top level index if (ib > kbl-1) cycle +! ! !**************************************************************************** @@ -858,12 +869,12 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & rainp = rain CALL CLOUD(K, KP1, IB, ntrc, kblmx, kblmn & - &, FRAC, MAX_NEG_BOUY, vsmooth, do_aw & + &, FRAC, MAX_NEG_BOUY, vsmooth, aw_scal & &, REVAP, WRKFUN, CALKBL, CRTFUN & &, DT, KDT, TLA, DPD & &, ALFINT, rhfacl, rhfacs, area(ipt) & &, ccwfac, CDRAG(ipt), trcfac & - &, alfind, rhc_l, phi_l, phi_h, PRS, PRSM,sgcs(1,ipt) & + &, alfind, rhc_l, phi_l, phi_h, PRS, PRSM,sgcs & &, TOI, QOI, UVI, QLI, QII, KBL, DDVEL(ipt) & &, TCU, QCU, RCU, PCU, FLX, FLXD, RAIN, WFNC, fscav_ & &, trcmin, ntk-2, c0, wminras(1), c0i, wminras(2) & @@ -880,15 +891,15 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ll = kp1 - ib dt_mf(ipt,ll) = dt_mf(ipt,ll) + flx(ib) - if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 + if (mp_phys == mp_phys_mg) then ! Anning Cheng for microphysics 11/14/2015 CNV_MFD(ipt,ll) = CNV_MFD(ipt,ll) + flx(ib)/dt -! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) -! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt +!! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) +!! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) + flx(ib)* & & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt -! & max(0.,(QLI(ib)+QII(ib)))/dt/3. +!! & max(0.,(QLI(ib)+QII(ib)))/dt/3. if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) & & ,ipt,ll endif @@ -901,16 +912,17 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & enddo dt_mf(ipt,ib) = dt_mf(ipt,ib) + flx(ib) - if (mp_phys == 10) then ! Anning Cheng for microphysics 11/14/2015 + if (mp_phys == mp_phys_mg) then ! Anning Cheng for microphysics 11/14/2015 CNV_MFD(ipt,ib) = CNV_MFD(ipt,ib) + flx(ib)/dt -! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) -! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt +!! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) +!! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) + flx(ib)* & & max(zero,(QLI(ib)+QII(ib)-qiid-qlid))/dt -! & max(0.,(QLI(ib)+QII(ib)))/dt/3. +!! & max(0.,(QLI(ib)+QII(ib)))/dt/3. if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) & & ,ipt,ib endif + endif ! ! @@ -944,9 +956,9 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! clw(i) = max(clw(i), zero) ! cli(i) = max(cli(i), zero) - if (sgcs(l,ipt) < 0.93_kp .and. abs(tcu(l)) > one_m10) then -! if (sgcs(l,ipt) < 0.90_kp .and. tcu(l) .ne. zero) then -! if (sgcs(l,ipt) < 0.85_kp .and. tcu(l) .ne. zero) then + if (sgcs(l) < 0.93_kp .and. abs(tcu(l)) > one_m10) then +! if (sgcs(l) < 0.90_kp .and. tcu(l) .ne. zero) then +! if (sgcs(l) < 0.85_kp .and. tcu(l) .ne. zero) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 @@ -967,7 +979,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & vin(ipt,ll) = uvi(l,ntr+2) ! V momentum !! for 2M microphysics, always output these variables - if (mp_phys == 10) then + if (mp_phys == mp_phys_mg) then if (advcld) then QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), zero) QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), zero) @@ -1018,7 +1030,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & vin(ipt,l) = uvi(l,ntr+2) ! V momentum !! for 2M microphysics, always output these variables - if (mp_phys == 10) then + if (mp_phys == mp_phys_mg) then if (advcld) then QLCN(ipt,l) = max(qli(l)-ccin(ipt,l,2), zero) QICN(ipt,l) = max(qii(l)-ccin(ipt,l,1), zero) @@ -1071,7 +1083,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & end subroutine rascnv_run SUBROUTINE CLOUD( & & K, KP1, KD, NTRC, KBLMX, kblmn & - &, FRACBL, MAX_NEG_BOUY, vsmooth, do_aw & + &, FRACBL, MAX_NEG_BOUY, vsmooth, aw_scal & &, REVAP, WRKFUN, CALKBL, CRTFUN & &, DT, KDT, TLA, DPD & &, ALFINT, RHFACL, RHFACS, area, ccwf, cd, trcfac & @@ -1145,7 +1157,8 @@ SUBROUTINE CLOUD( & &, RHRAM=0.05_kp & ! PBL RELATIVE HUMIDITY RAMP ! &, RHRAM=0.15_kp !& ! PBL RELATIVE HUMIDITY RAMP &, HCRITD=4000.0_kp & ! Critical Moist Static Energy for Deep clouds - &, HCRITS=2000.0_kp & ! Critical Moist Static Energy for Shallow clouds +! &, HCRITS=2000.0_kp & ! Critical Moist Static Energy for Shallow clouds + &, HCRITS=2500.0_kp & ! Critical Moist Static Energy for Shallow clouds &, pcrit_lcl=250.0_kp & ! Critical pressure difference between boundary layer top ! layer top and lifting condensation level (hPa) ! &, hpert_fac=1.01_kp !& ! Perturbation on hbl when ctei=.true. @@ -1172,7 +1185,7 @@ SUBROUTINE CLOUD( & ! LOGICAL REVAP, WRKFUN, CALKBL, CRTFUN, CALCUP, ctei LOGICAL REVAP, WRKFUN, CALKBL, CRTFUN, CALCUP - logical vsmooth, do_aw + logical vsmooth, aw_scal INTEGER K, KP1, KD, NTRC, kblmx, kblmn, ntk @@ -1405,7 +1418,8 @@ SUBROUTINE CLOUD( & hmax = hol(kmax) elseif (kmax < k) then do l=kmax+1,k - if (abs(hol(kmax)-hol(l)) > half * hcrit) then +! if (abs(hol(kmax)-hol(l)) > half * hcrit) then + if (abs(hol(kmax)-hol(l)) > hcrit) then kmxb = l - 1 exit endif @@ -1435,7 +1449,6 @@ SUBROUTINE CLOUD( & endif enddo endif - ! klcl = kd1 if (kmax > kd1) then @@ -1446,7 +1459,6 @@ SUBROUTINE CLOUD( & endif enddo endif -! if (klcl == kd .or. klcl < ktem) return ! This is to handle mid-level convection from quasi-uniform h @@ -1464,7 +1476,6 @@ SUBROUTINE CLOUD( & tem = min(50.0_kp,max(10.0_kp,(prl(kmaxp1)-prl(kd))*0.10_kp)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii - if (kbl .ne. ii) then if (PRL(kmaxp1)-PRL(KBL) > bldmax) kbl = max(kbl,ii) endif @@ -1494,7 +1505,6 @@ SUBROUTINE CLOUD( & ! endif ! if (kbl == kblmx .and. kmax >= km1) kbl = k - 1 !!! - KPBL = KBL ELSE @@ -1504,12 +1514,10 @@ SUBROUTINE CLOUD( & KBL = min(kmax,MAX(KBL,KD+2)) KB1 = KBL - 1 !! - if (PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd ) then ! & .or. PRL(Kmaxp1)-PRL(KBL) < bldmin) then return endif -! ! PRIS = ONE / (PRL(KP1)-PRL(KBL)) PRISM = ONE / (PRL(Kmaxp1)-PRL(KBL)) @@ -1606,7 +1614,7 @@ SUBROUTINE CLOUD( & ENDDO ENDDO ! -! if (ntk > 0 .and. do_aw) then +! if (ntk > 0 .and. aw_scal) then if (ntk > 0) then if (rbl(ntk) > zero) then wcbase = min(two, max(wcbase, sqrt(twoo3*rbl(ntk)))) @@ -1710,6 +1718,7 @@ SUBROUTINE CLOUD( & qi00 = qi0 ii = 0 777 continue + ! ep_wfn = .false. RNN(KBL) = zero @@ -1734,7 +1743,6 @@ SUBROUTINE CLOUD( & ALM = ALHF*QIL(KD) - LTL(KD) * VTF(KD) ! HSU = HST(KD) + LTL(KD) * NU * (QOL(KD)-QST(KD)) - ! !===> VERTICAL INTEGRALS NEEDED TO COMPUTE THE ENTRAINMENT PARAMETER ! @@ -1787,10 +1795,8 @@ SUBROUTINE CLOUD( & if (tem1 > almax) tem1 = -100.0_kp if (tem2 > almax) tem2 = -100.0_kp alm = max(tem1,tem2) - endif endif - ! ! CLIP CASE: ! NON-ENTRAINIG CLOUD DETRAINS IN LOWER HALF OF TOP LAYER. @@ -1887,7 +1893,6 @@ SUBROUTINE CLOUD( & ETAI(L) = one / ETA(L) ENDDO ETAI(KBL) = one - ! !===> CLOUD WORKFUNCTION ! @@ -2046,7 +2051,6 @@ SUBROUTINE CLOUD( & TEM = max(0.05_kp, MIN(CD*200.0_kp, MAX_NEG_BOUY)) IF (.not. cnvflg .and. WFN > ACR .and. & & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. - ! !===> IF NO SOUNDING MEETS THIRD CONDITION, RETURN ! @@ -2118,7 +2122,6 @@ SUBROUTINE CLOUD( & ENDDO ENDIF - ! !===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX ! Includes downdraft terms! @@ -2145,7 +2148,6 @@ SUBROUTINE CLOUD( & GMS(KD) = (DS + st1 - tem1*det*alhl-tem*alhf) * PRI(KD) GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + DH) - ! ! TENDENCY FOR SUSPENDED ENVIRONMENTAL ICE AND/OR LIQUID WATER ! @@ -2185,7 +2187,6 @@ SUBROUTINE CLOUD( & GMH(L) = DH * PRI(L) GMS(L) = DS * PRI(L) - ! GHD(L) = TEM5 * PRI(L) GSD(L) = (TEM5 - ALHL * TEM6) * PRI(L) @@ -2225,7 +2226,6 @@ SUBROUTINE CLOUD( & GMS(K) = GMS(K) + TEM2 GHD(K) = GHD(K) + TEM1 GSD(K) = GSD(K) + TEM2 - ! avh = avh + gmh(K)*(prs(KP1)-prs(K)) ! @@ -2241,7 +2241,7 @@ SUBROUTINE CLOUD( & ! avh = avh + tx1*(prs(l+1)-prs(l)) ENDDO - +! ! !*********************************************************************** !*********************************************************************** @@ -2304,7 +2304,6 @@ SUBROUTINE CLOUD( & ! qbl = qbl * hpert_fac ! endif - !*********************************************************************** !===> CLOUD WORKFUNCTION FOR MODIFIED SOUNDING, THEN KERNEL (AKM) @@ -2400,7 +2399,7 @@ SUBROUTINE CLOUD( & ! tx1 = one - amb * eta(kd) / (rho(kd)*wvl(kd)) ! sigf(kd) = max(zero, min(one, tx1 * tx1)) ! endif - if (do_aw) then + if (aw_scal) then tx1 = (0.2_kp / max(alm, 1.0e-5_kp)) tx2 = one - min(one, pi * tx1 * tx1 / area) @@ -2426,6 +2425,9 @@ SUBROUTINE CLOUD( & else sigf(kd:k) = one endif + + tx1 = max(1.0e-3_kp, abs(gms(kd) * onebcp * sigf(kd))) + amb = min(tx1*amb, tfrac_max*toi(kd)) / tx1 ! avt = zero avq = zero @@ -2511,7 +2513,6 @@ SUBROUTINE CLOUD( & ! enddo ! endif -! ! TX1 = zero TX2 = zero @@ -2576,7 +2577,6 @@ SUBROUTINE CLOUD( & & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778_kp )) ACTEVAP = MIN(TX1, TEM4*CLFRAC) - if (tx1 < rainmin*dt) actevap = min(tx1, potevap) ! tem4 = zero @@ -2593,7 +2593,7 @@ SUBROUTINE CLOUD( & ! ST1 = ST1 * ELOCP - TOI(L) = TOI(L) - ST1 + TOI(L) = TOI(L) - ST1 TCU(L) = TCU(L) - ST1 ENDIF ENDIF @@ -2606,7 +2606,6 @@ SUBROUTINE CLOUD( & ENDDO CUP = CUP + TX1 + DOF * AMB * sigf(kbl) ENDIF - ! ! Convective transport (mixing) of passive tracers ! @@ -2639,10 +2638,11 @@ SUBROUTINE CLOUD( & HOD(L) = HB ENDIF ENDDO - + DO L=KB1,KD,-1 HCC = HCC + (ETA(L)-ETA(L+1))*HOL(L) ENDDO + ! ! Scavenging -- fscav - fraction scavenged [km-1] ! delz - distance from the entrainment to detrainment layer [km] @@ -2690,7 +2690,7 @@ SUBROUTINE CLOUD( & RCU(L,N) = RCU(L,N) + ST1 st2 = zero endif - + ENDDO ENDDO ! Tracer loop NTRC endif @@ -3300,6 +3300,7 @@ SUBROUTINE DDRFT( & ! endif ELSE ERRQ = TX2 ! Further iteration ! + ! if (itr == itrmu .and. ERRQ > ERRMIN*10 & ! & .and. ntla == 1) ERRQ = 10.0 ENDIF @@ -3462,8 +3463,6 @@ SUBROUTINE DDRFT( & VT(1) = GMS(L-1) * QRPF(QRP(L-1)) RNT = ROR(L-1) * (WVL(L-1)+VT(1))*QRP(L-1) -! - ! TEM = MAX(ALM, 2.5E-4) * MAX(ETA(L), 1.0) TEM = MAX(ALM,ONE_M6) * MAX(ETA(L), ONE) ! TEM = MAX(ALM, 1.0E-5) * MAX(ETA(L), 1.0) @@ -3559,7 +3558,7 @@ SUBROUTINE DDRFT( & TEM2 = TX8 ST1 = zero ENDIF -! + st2 = tx5 TEM = ROR(L)*WVL(L) - ROR(L-1)*WVL(L-1) if (tem > zero) then @@ -3620,6 +3619,7 @@ SUBROUTINE DDRFT( & ENDIF ERRH = HOD(L) - TEM1 ERRQ = ABS(ERRH/HOD(L)) + ABS(ERRE/MAX(ETD(L),ONE_M5)) + DOF = DDZ VT(2) = QQQ ! @@ -3678,6 +3678,7 @@ SUBROUTINE DDRFT( & ! Compute Buoyancy TEM1 = WA(3) + (HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & & * onebcp + TEM1 = TEM1 * (one + NU*QOD(L)) ROR(L) = CMPOR * PRL(L) / TEM1 TEM1 = TEM1 * DOFW @@ -3689,6 +3690,7 @@ SUBROUTINE DDRFT( & TEM1 = WVL(L) WVL(L) = VT(2) * (ETD(L-1)*WVL(L-1) - FACG & & * (BUY(L-1)*QRT(L-1)+BUY(L)*QRB(L-1))) +! ! if (wvl(l) < zero) then ! WVL(L) = max(wvl(l), 0.1*tem1) @@ -3709,7 +3711,9 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2_kp) THEN + ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3878,7 +3882,6 @@ SUBROUTINE DDRFT( & if (tx5 > zero) idnm = idnm + 1 endif ENDIF - ! ! If downdraft properties are not obtainable, (i.e.solution does ! not converge) , no downdraft is assumed @@ -4095,7 +4098,7 @@ end subroutine qrabf SUBROUTINE SETVTP implicit none - real(kind=kind_phys), parameter :: vtpexp=-0.3636_kp, one=1.0_kp + real(kind=kind_phys), parameter :: vtpexp=-0.3636_kp real(kind=kind_phys) xinc,x,xmax,xmin integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/physics/rascnv.meta b/physics/rascnv.meta index cac328186..4babf620d 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rascnv type = scheme - dependencies = + dependencies = funcphys.f90,machine.F ######################################################################## [ccpp-arg-table] From 30472fb57d94e19ddf0dddc6828f0543a03fe35a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 25 Feb 2021 14:24:57 -0500 Subject: [PATCH 031/165] after merging with ccpp/master and adding change to average ln(z0) --- physics/GFS_suite_interstitial.F90 | 16 ++++++++-------- physics/GFS_surface_composites.F90 | 10 +++++++--- physics/sfc_drv.f | 3 +-- 3 files changed, 16 insertions(+), 13 deletions(-) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index c465f74e7..a198c10bb 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -230,8 +230,8 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... sfc lw fluxes used by atmospheric model are saved for output if (.not. use_LW_jacobian) then - if (frac_grid) then - do i=1,im + if (frac_grid) then + do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & @@ -242,9 +242,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl + adjsfculw_ice(i) * tem & + adjsfculw_wat(i) * (one - frland(i) - tem) endif - enddo - else - do i=1,im + enddo + else + do i=1,im if (dry(i)) then ! all land adjsfculw(i) = adjsfculw_lnd(i) elseif (icy(i)) then ! ice (and water) @@ -265,15 +265,15 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl else ! all water adjsfculw(i) = adjsfculw_wat(i) endif - enddo - endif + enddo + endif endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - end do + enddo if (ldiag3d) then if (lsidea) then diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index bb53f9220..a70675c90 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -448,7 +448,9 @@ subroutine GFS_surface_composites_post_run ( txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell txo = max(zero, wfrac-txi) ! txo = open water fraction - zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) +! zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) + zorl(i) = txl*log(zorl_lnd(i)) + txi*log(zorl_ice(i)) + txo*log(zorl_wat(i)) + zorl(i) = exp(zorl(i)) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) cdq(i) = txl*cdq_lnd(i) + txi*cdq_ice(i) + txo*cdq_wat(i) rb(i) = txl*rb_lnd(i) + txi*rb_ice(i) + txo*rb_wat(i) @@ -625,11 +627,13 @@ subroutine GFS_surface_composites_post_run ( stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) + zorl(i) = txi * log(zorl_ice(i)) + txo * log(zorl_wat(i)) + zorl(i) = exp(zorl(i)) snowd(i) = txi * snowd_ice(i) endif elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = cice(i)*zorl_ice(i) + (one-cice(i))*zorl_wat(i) + zorl(i) = cice(i)*log(zorl_ice(i)) + (one-cice(i))*log(zorl_wat(i)) + zorl(i) = exp(zorl(i)) endif ! if (wet(i)) then diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 4343d5dff..0564b8e46 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -559,8 +559,7 @@ subroutine lsm_noah_run & snwdph(i) = snowh * 1000.0_kind_phys weasd(i) = sneqv * 1000.0_kind_phys sncovr1(i) = sncovr -! ---- ... outside sflx, roughness uses cm as unit (update after snow's -! effect) +! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) zorl(i) = z0*100.0_kind_phys !> - Do not return the following output fields to parent model: From 60c9a72019e1c7a5fd5c89bdc0969d76d3c831f6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 26 Feb 2021 20:33:56 -0500 Subject: [PATCH 032/165] replacing flag_cice by kdt --- physics/GFS_PBL_generic.F90 | 13 ++++++------- physics/GFS_PBL_generic.meta | 16 ++++++++-------- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 357309b2a..10b312075 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -308,7 +308,7 @@ end subroutine GFS_PBL_generic_post_finalize !! subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, & ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev,nqrimef, & - trans_aero, ntchs, ntchm, & + trans_aero, ntchs, ntchm, kdt, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, imp_physics_zhao_carr, imp_physics_mg, & imp_physics_fer_hires, & ltaerosol, cplflx, cplchm, lssav, flag_for_pbl_generic_tend, ldiag3d, qdiag3d, lsidea, hybedmf, do_shoc, satmedmf, & @@ -316,7 +316,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqdt, dusfc_cpl, dvsfc_cpl, dtsfc_cpl, & dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, & - dq3dt_ozone, rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, flag_cice, dusfc_cice, dvsfc_cice, & + dq3dt_ozone, rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, dusfc_cice, dvsfc_cice, & dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, hefac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) @@ -326,14 +326,13 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, implicit none integer, parameter :: kp = kind_phys - integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm + integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm, kdt integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef logical, intent(in) :: trans_aero integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, qdiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu - logical, dimension(:), intent(in) :: flag_cice logical, intent(in) :: flag_for_pbl_generic_tend real(kind=kind_phys), dimension(im, levs), intent(in) :: save_u, save_v, save_t @@ -547,14 +546,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (cplflx) then do i=1,im - if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES + if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES if ( .not. wet(i)) then ! no open water - if (flag_cice(i)) then !use results from CICE + if (kdt > 1) then !use results from CICE dusfci_cpl(i) = dusfc_cice(i) dvsfci_cpl(i) = dvsfc_cice(i) dtsfci_cpl(i) = dtsfc_cice(i) dqsfci_cpl(i) = dqsfc_cice(i) - else !use PBL fluxes when CICE fluxes is unavailable + else !use PBL fluxes when CICE fluxes is unavailable dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) dtsfci_cpl(i) = dtsfc1(i) diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 5e83b8ad4..68f3459c3 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -620,6 +620,14 @@ type = integer intent = in optional = F +[kdt] + standard_name = index_of_time_step + long_name = current number of time steps + units = index + dimensions = () + type = integer + intent = in + optional = F [imp_physics] standard_name = flag_for_microphysics_scheme long_name = choice of microphysics scheme @@ -1194,14 +1202,6 @@ kind = kind_phys intent = in optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F [dusfc_cice] standard_name = surface_x_momentum_flux_for_coupling long_name = sfc x momentum flux for coupling From 925020b72d242ff6101f167a14c0a535c865e987 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 28 Feb 2021 20:30:59 -0500 Subject: [PATCH 033/165] minor update of ras --- physics/rascnv.F90 | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 34b3031f1..9c47144ac 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -1160,13 +1160,15 @@ SUBROUTINE CLOUD( & ! &, HCRITS=2000.0_kp & ! Critical Moist Static Energy for Shallow clouds &, HCRITS=2500.0_kp & ! Critical Moist Static Energy for Shallow clouds &, pcrit_lcl=250.0_kp & ! Critical pressure difference between boundary layer top - ! layer top and lifting condensation level (hPa) -! &, hpert_fac=1.01_kp !& ! Perturbation on hbl when ctei=.true. -! &, hpert_fac=1.005_kp !& ! Perturbation on hbl when ctei=.true. + ! layer top and lifting condensation level (hPa) +! &, hpert_fac=1.01_kp & ! Perturbation on hbl when ctei=.true. +! &, hpert_fac=1.005_kp & ! Perturbation on hbl when ctei=.true. &, qudfac=quad_lam*half & &, shalfac=3.0_kp & ! &, qudfac=quad_lam*pt25, shalfac=3.0_kp !& ! Yogesh's - &, c0ifac=0.07_kp & ! following Han et al, 2016 MWR +! &, c0ifac=0.07_kp & ! following Han et al, 2016 MWR +! &, c0ifac=0.001_kp & ! following Han et al, 2017 Weather and Forecasting + &, c0ifac=0.0_kp & &, dpnegcr = 150.0_kp ! &, dpnegcr = 100.0_kp ! &, dpnegcr = 200.0_kp @@ -1679,7 +1681,8 @@ SUBROUTINE CLOUD( & QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE ! st1 = qil(kd) - st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,zero)) + st2 = c0i * st1 + if (c0ifac > 1.0e-6_kp) st2 = st2 * exp(c0ifac*min(tol(kd)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! @@ -1701,7 +1704,8 @@ SUBROUTINE CLOUD( & AKC(L) = one / AKT(L) ! st1 = half * (qil(l)+qil(lp1)) - st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,zero)) + st2 = c0i * st1 + if (c0ifac > 1.0e-6_kp) st2 = st2 * exp(c0ifac*min(tol(lp1)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! From 04132df0df29959d71a7e7247b07ad380ecc0c21 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 2 Mar 2021 19:37:24 -0500 Subject: [PATCH 034/165] updating the setemis routine to use landfrac and fice --- physics/dcyc2.f | 6 +-- physics/radiation_surface.f | 88 ++++++++++++++++++++++--------------- physics/rrtmg_lw_pre.F90 | 12 ++--- physics/rrtmg_lw_pre.meta | 17 +++++-- physics/rrtmgp_lw_pre.F90 | 9 ++-- physics/rrtmgp_lw_pre.meta | 17 +++++-- 6 files changed, 93 insertions(+), 56 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 389496d07..2033fd875 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -296,15 +296,15 @@ subroutine dcyc2t3_run & ! do i = 1, im - tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 - adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !> - LW time-step adjustment: if (use_LW_Jacobian) then ! F_adj = F_o + (dF/dT) * dT dT = tf(i) - tsflw(i) adjsfculw(i) = sfculw(i) + sfculw_jac(i) * dT else + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. !! compute 4th power of the ratio of \c tf in the lowest model layer over the mean value \c tsflw. if (dry(i)) then diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 9cbeb733b..f2d2b4350 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -122,6 +122,7 @@ module module_radiation_surface integer, parameter, public :: JMXEMS = 180 !< number of latitude points in global emis-type map real (kind=kind_phys), parameter :: f_zero = 0.0 real (kind=kind_phys), parameter :: f_one = 1.0 + real (kind=kind_phys), parameter :: epsln = 1.0e-6 real (kind=kind_phys), parameter :: rad2dg= 180.0 / con_pi integer, allocatable :: idxems(:,:) !< global surface emissivity index array integer :: iemslw = 0 !< global surface emissivity control flag set up in 'sfc_init' @@ -659,7 +660,8 @@ end subroutine setalb !! or -pi -> +pi ranges !!\param xlat (IMAX), latitude in radiance, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param slmsk (IMAX), sea(0),land(1),ice(2) mask on fcst model grid +!!\param lanfrac (IMAX), +!!!\parction of grid that is land !!\param snowf (IMAX), snow depth water equivalent in mm !!\param sncovr (IMAX), snow cover over land !!\param zorlf (IMAX), surface roughness in cm @@ -672,8 +674,8 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, & ! --- inputs: - & IMAX, & + & ( xlon,xlat,landfrac,snowf,sncovr,fice,zorlf,tsknf,tairf, & ! --- inputs: + & hprif, IMAX, & & sfcemis & ! --- outputs: & ) @@ -688,21 +690,23 @@ subroutine setemis & ! ==================== defination of variables ==================== ! ! ! ! inputs: ! -! xlon (IMAX) - longitude in radiance, ok for both 0->2pi or ! -! -pi -> +pi ranges ! -! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! -! range, otherwise see in-line comment ! -! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! snowf (IMAX) - snow depth water equivalent in mm ! -! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! -! zorlf (IMAX) - surface roughness in cm ! -! tsknf (IMAX) - ground surface temperature in k ! -! tairf (IMAX) - lowest model layer air temperature in k ! -! hprif (IMAX) - topographic sdv in m ! -! IMAX - array horizontal dimension ! +! xlon (IMAX) - longitude in radiance, ok for both 0->2pi or ! +! -pi -> +pi ranges ! +! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! +! range, otherwise see in-line comment ! +!! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! +! landfrac (IMAX) - fraction of land on on fcst model grid ! +! snowf (IMAX) - snow depth water equivalent in mm ! +! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! +! fice (IMAX) - sea/lake ice fraction ! +! zorlf (IMAX) - surface roughness in cm ! +! tsknf (IMAX) - ground surface temperature in k ! +! tairf (IMAX) - lowest model layer air temperature in k ! +! hprif (IMAX) - topographic sdv in m ! +! IMAX - array horizontal dimension ! ! ! ! outputs: ! -! sfcemis(IMAX) - surface emissivity ! +! sfcemis(IMAX) - surface emissivity ! ! ! ! ------------------------------------------------------------------- ! ! ! @@ -722,7 +726,8 @@ subroutine setemis & integer, intent(in) :: IMAX real (kind=kind_phys), dimension(:), intent(in) :: & - & xlon,xlat, slmsk, snowf,sncovr, zorlf, tsknf, tairf, hprif + & xlon, xlat, landfrac, snowf, sncovr, fice, zorlf, tsknf, & + & tairf, hprif ! --- outputs real (kind=kind_phys), dimension(:), intent(out) :: sfcemis @@ -731,7 +736,7 @@ subroutine setemis & integer :: i, i1, i2, j1, j2, idx real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & - & asnow, argh, hrgh, fsno, fsno0, fsno1 + & asnow, argh, hrgh, fsno, fsno0, fracl, fraco, fraci ! --- reference emiss value for diff surface emiss index ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, @@ -756,19 +761,25 @@ subroutine setemis & ! --- ... mapping input data onto model grid ! note: this is a simple mapping method, an upgrade is needed if -! the model grid is much corcer than the 1-deg data resolution +! the model grid is much coarser than the 1-deg data resolution lab_do_IMAX : do i = 1, IMAX - if ( nint(slmsk(i)) == 0 ) then ! sea point - - sfcemis(i) = emsref(1) + fracl = landfrac(i) + fraco = max(f_zero, f_one - fracl) + fraci = fraco * fice(i) + fraco = max(f_zero, fraco-fraci) - else if ( nint(slmsk(i)) == 2 ) then ! sea-ice - - sfcemis(i) = emsref(7) + if (fracl < epsln) then ! no land + if ( abs(fraco-f_one) < epsln ) then ! open water point + sfcemis(i) = emsref(1) + elseif ( abs(fraci-f_one) > epsln ) then ! complete sea/lake ice + sfcemis(i) = emsref(7) + else + sfcemis(i) = fraco*emsref(1) + fraci*emsref(7) + endif - else ! land + else ! land or fractional grid ! --- map grid in longitude direction i2 = 1 @@ -799,20 +810,25 @@ subroutine setemis & endif enddo lab_do_JMXEMS - idx = max( 2, idxems(i2,j2) ) if ( idx >= 7 ) idx = 2 - sfcemis(i) = emsref(idx) + + if (abs(fracl-f_one) < epsln) then + sfcemis(i) = emsref(idx) + else + sfcemis(i) = fracl*emsref(idx) + fraco*emsref(1) & + & + fraci*emsref(7) + endif endif ! end if_slmsk_block !> -# Check for snow covered area. - if ( ialbflg==1 .and. nint(slmsk(i))==1 ) then ! input land area snow cover +! if ( ialbflg==1 .and. nint(slmsk(i))==1 ) then ! input land area snow cover + if ( sncovr(i) > f_zero ) then ! input land/ice area snow cover fsno0 = sncovr(i) - fsno1 = f_one - fsno0 - sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 + sfcemis(i) = sfcemis(i)*(f_one - fsno0) + emsref(8)*fsno0 else ! compute snow cover from snow depth if ( snowf(i) > f_zero ) then @@ -820,10 +836,12 @@ subroutine setemis & argh = min(0.50, max(.025, 0.01*zorlf(i))) hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) fsno0 = asnow / (argh + asnow) * hrgh - if (nint(slmsk(i)) == 0 .and. tsknf(i) > 271.2) & - & fsno0=f_zero - fsno1 = f_one - fsno0 - sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 + +! if (nint(slmsk(i)) == 0 .and. tsknf(i) > 271.2) & +! & fsno0=f_zero + + if (abs(fraco-f_one) < epsln) fsno0 = f_zero ! no snow over open water + sfcemis(i) = sfcemis(i)*(f_one - fsno0) + emsref(8)*fsno0 endif endif ! end if_ialbflg diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index d96a1f486..dfb545997 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -12,8 +12,8 @@ end subroutine rrtmg_lw_pre_init !> \section arg_table_rrtmg_lw_pre_run Argument Table !! \htmlinclude rrtmg_lw_pre_run.html !! - subroutine rrtmg_lw_pre_run (im, lslwr, xlat, xlon, slmsk, snowd, sncovr,& - zorl, hprime, tsfg, tsfa, semis, errmsg, errflg) + subroutine rrtmg_lw_pre_run (im, lslwr, xlat, xlon, landfrac, snowd, sncovr,& + fice, zorl, hprime, tsfg, tsfa, semis, errmsg, errflg) use machine, only: kind_phys use module_radiation_surface, only: setemis @@ -22,8 +22,8 @@ subroutine rrtmg_lw_pre_run (im, lslwr, xlat, xlon, slmsk, snowd, sncovr,& integer, intent(in) :: im logical, intent(in) :: lslwr - real(kind=kind_phys), dimension(im), intent(in) :: xlat, xlon, slmsk, & - snowd, sncovr, zorl, hprime, tsfg, tsfa + real(kind=kind_phys), dimension(im), intent(in) :: xlat, xlon, landfrac, & + snowd, sncovr, fice, zorl, hprime, tsfg, tsfa real(kind=kind_phys), dimension(im), intent(out) :: semis character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -35,8 +35,8 @@ subroutine rrtmg_lw_pre_run (im, lslwr, xlat, xlon, slmsk, snowd, sncovr,& if (lslwr) then !> - Call module_radiation_surface::setemis(),to setup surface !! emissivity for LW radiation. - call setemis (xlon, xlat, slmsk, snowd, sncovr, zorl, tsfg, tsfa, & - hprime, im, & ! --- inputs + call setemis (xlon, xlat, landfrac, snowd, sncovr, fice, zorl, tsfg, tsfa, & + hprime, im, & ! --- inputs semis) ! --- outputs endif diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta index bfb0bd61f..fa32214d0 100644 --- a/physics/rrtmg_lw_pre.meta +++ b/physics/rrtmg_lw_pre.meta @@ -41,10 +41,10 @@ kind = kind_phys intent = in optional = F -[slmsk] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -68,6 +68,15 @@ kind = kind_phys intent = in optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [zorl] standard_name = surface_roughness_length long_name = surface roughness length diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 index 907230180..3e0664583 100644 --- a/physics/rrtmgp_lw_pre.F90 +++ b/physics/rrtmgp_lw_pre.F90 @@ -25,8 +25,8 @@ end subroutine rrtmgp_lw_pre_init !> \section arg_table_rrtmgp_lw_pre_run !! \htmlinclude rrtmgp_lw_pre_run.html !! - subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, sncovr, & - tsfg, tsfa, hprime, sfc_emiss_byband, semis, errmsg, errflg) + subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, landfrac, zorl, snowd, sncovr, & + fice, tsfg, tsfa, hprime, sfc_emiss_byband, semis, errmsg, errflg) ! Inputs logical, intent(in) :: & @@ -36,10 +36,11 @@ subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, snc real(kind_phys), dimension(nCol), intent(in) :: & xlon, & ! Longitude xlat, & ! Latitude - slmsk, & ! Land/sea/sea-ice mask + landfrac, & ! Land fraction zorl, & ! Surface roughness length (cm) snowd, & ! water equivalent snow depth (mm) sncovr, & ! Surface snow are fraction (1) + fice, & ! Sea/Lake ice fraction (1) tsfg, & ! Surface ground temperature for radiation (K) tsfa, & ! Lowest model layer air temperature for radiation (K) hprime ! Standard deviation of subgrid orography @@ -66,7 +67,7 @@ subroutine rrtmgp_lw_pre_run (doLWrad, nCol, xlon, xlat, slmsk, zorl, snowd, snc ! ####################################################################################### ! Call module_radiation_surface::setemis(),to setup surface emissivity for LW radiation. ! ####################################################################################### - call setemis (xlon, xlat, slmsk, snowd, sncovr, zorl, tsfg, tsfa, hprime, nCol, semis) + call setemis (xlon, xlat, landfrac, snowd, sncovr, fice, zorl, tsfg, tsfa, hprime, nCol, semis) ! Assign same emissivity to all bands do iBand=1,lw_gas_props%get_nband() diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index af287b2f7..aa021b21d 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -41,10 +41,10 @@ kind = kind_phys intent = in optional = F -[slmsk] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -77,6 +77,15 @@ kind = kind_phys intent = in optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [tsfg] standard_name = surface_ground_temperature_for_radiation long_name = surface ground temperature for radiation From 042672e1a8ef6b47b28ba90740e0d1fe16aaa1b4 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sun, 7 Mar 2021 21:27:02 -0500 Subject: [PATCH 035/165] some fixes im MGx and radsw_main --- physics/m_micro.F90 | 9 ++++++ physics/micro_mg2_0.F90 | 20 ++++++------ physics/micro_mg3_0.F90 | 20 ++++++------ physics/radsw_main.F90 | 72 ++++++++++++++++++++++++++++++++--------- 4 files changed, 87 insertions(+), 34 deletions(-) diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 77b51ed62..8e6d6698e 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -542,16 +542,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & NCPI(I,K), qc_min) if (rnw(i,k) <= qc_min(1)) then ncpr(i,k) = zero + rnw(i,k) = zero elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero + snw(i,k) = zero elseif (ncps(i,k) <= nmin) then ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero + qgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif @@ -1696,16 +1699,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & QI_TOT(I,K) = QILS(I,K) + QICN(I,K) if (rnw(i,k) <= qc_min(1)) then ncpr(i,k) = zero + rnw(i,k) = zero elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero + snw(i,k) = zero elseif (ncps(i,k) <= nmin) then ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero + qgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif @@ -1736,16 +1742,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! if (rnw(i,k) <= qc_min(1)) then ncpr(i,k) = zero + rnw(i,k) = zero elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then ncps(i,k) = zero + snw(i,k) = zero elseif (ncps(i,k) <= nmin) then ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then ncgl(i,k) = zero + qgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif diff --git a/physics/micro_mg2_0.F90 b/physics/micro_mg2_0.F90 index 744b46ebc..73c46392d 100644 --- a/physics/micro_mg2_0.F90 +++ b/physics/micro_mg2_0.F90 @@ -1792,7 +1792,7 @@ subroutine micro_mg_tend ( & nnucct(i,k) = ratio * nnucct(i,k) npsacws(i,k) = ratio * npsacws(i,k) nsubc(i,k) = ratio * nsubc(i,k) - end if + endif mnuccri(i,k) = zero nnuccri(i,k) = zero @@ -1800,15 +1800,17 @@ subroutine micro_mg_tend ( & if (do_cldice) then ! freezing of rain to produce ice if mean rain size is smaller than Dcs - if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = zero - nnuccr(i,k) = zero - end if - end if + if (lamr(i,k) > qsmall) then + if (one/lamr(i,k) < Dcs) then + mnuccri(i,k) = mnuccr(i,k) + nnuccri(i,k) = nnuccr(i,k) + mnuccr(i,k) = zero + nnuccr(i,k) = zero + endif + endif + endif - end do + enddo do i=1,mgncol diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 636293b86..dde143c4d 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -2448,7 +2448,7 @@ subroutine micro_mg_tend ( & nnucct(i,k) = ratio * nnucct(i,k) npsacws(i,k) = ratio * npsacws(i,k) nsubc(i,k) = ratio * nsubc(i,k) - end if + endif mnuccri(i,k) = zero nnuccri(i,k) = zero @@ -2456,15 +2456,17 @@ subroutine micro_mg_tend ( & if (do_cldice) then ! freezing of rain to produce ice if mean rain size is smaller than Dcs - if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = zero - nnuccr(i,k) = zero - end if - end if + if (lamr(i,k) > qsmall) then + if (one/lamr(i,k) < Dcs) then + mnuccri(i,k) = mnuccr(i,k) + nnuccri(i,k) = nnuccr(i,k) + mnuccr(i,k) = zero + nnuccr(i,k) = zero + endif + endif + endif - end do + enddo do i=1,mgncol diff --git a/physics/radsw_main.F90 b/physics/radsw_main.F90 index 8ebbb3ab1..77fd61fcc 100644 --- a/physics/radsw_main.F90 +++ b/physics/radsw_main.F90 @@ -2946,8 +2946,13 @@ subroutine spcvrtc & else ! for non-conservative scattering za1 = zgam1*zgam4 + zgam2*zgam3 za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk + zrk = (zgam1 - zgam2) * (zgam1 + zgam2) + if (zrk > eps1) then + zrk = sqrt(zrk) + else + zrk = f_zero + endif + zrk2= zrk + zrk zrp = zrk * cosz zrp1 = f_one + zrp @@ -2993,7 +2998,8 @@ subroutine spcvrtc & ze1r45 = zr4*zexp1 + zr5*zexm1 ! ... collimated beam - if (ze1r45>=-eps1 .and. ze1r45<=eps1) then +! if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + if (abs(ze1r45) <= eps1) then zrefb(kp) = eps1 ztrab(kp) = zexm2 else @@ -3005,7 +3011,11 @@ subroutine spcvrtc & endif ! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) + if (ze1r45 >= f_zero) then + zden1 = zr4 / max(eps1, ze1r45*zrkg1) + else + zden1 = zr4 / min(-eps1, ze1r45*zrkg1) + endif zrefd(kp) = max(f_zero, min(f_one, & & zgam2*(zexp1 - zexm1)*zden1 )) ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) @@ -3171,8 +3181,13 @@ subroutine spcvrtc & else ! for non-conservative scattering za1 = zgam1*zgam4 + zgam2*zgam3 za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk + zrk = (zgam1 - zgam2) * (zgam1 + zgam2) + if (zrk > eps1) then + zrk = sqrt(zrk) + else + zrk = f_zero + endif + zrk2= zrk + zrk zrp = zrk * cosz zrp1 = f_one + zrp @@ -3218,7 +3233,8 @@ subroutine spcvrtc & ze1r45 = zr4*zexp1 + zr5*zexm1 ! ... collimated beam - if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then +! if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + if ( abs(ze1r45) <= eps1 ) then zrefb(kp) = eps1 ztrab(kp) = zexm2 else @@ -3230,7 +3246,11 @@ subroutine spcvrtc & endif ! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) + if (ze1r45 >= f_zero) then + zden1 = zr4 / max(eps1, ze1r45*zrkg1) + else + zden1 = zr4 / min(-eps1, ze1r45*zrkg1) + endif zrefd(kp) = max(f_zero, min(f_one, & & zgam2*(zexp1 - zexm1)*zden1 )) ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) @@ -3723,8 +3743,13 @@ subroutine spcvrtm & else ! for non-conservative scattering za1 = zgam1*zgam4 + zgam2*zgam3 za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk + zrk = (zgam1 - zgam2) * (zgam1 + zgam2) + if (zrk > eps1) then + zrk = sqrt(zrk) + else + zrk = f_zero + endif + zrk2= zrk + zrk zrp = zrk * cosz zrp1 = f_one + zrp @@ -3770,7 +3795,8 @@ subroutine spcvrtm & ze1r45 = zr4*zexp1 + zr5*zexm1 ! ... collimated beam - if (ze1r45>=-eps1 .and. ze1r45<=eps1) then +! if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + if (abs(ze1r45) <= eps1) then zrefb(kp) = eps1 ztrab(kp) = zexm2 else @@ -3782,7 +3808,11 @@ subroutine spcvrtm & endif ! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) + if (ze1r45 >= f_zero) then + zden1 = zr4 / max(eps1, ze1r45*zrkg1) + else + zden1 = zr4 / min(-eps1, ze1r45*zrkg1) + endif zrefd(kp) = max(f_zero, min(f_one, & & zgam2*(zexp1 - zexm1)*zden1 )) ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) @@ -3935,8 +3965,13 @@ subroutine spcvrtm & else ! for non-conservative scattering za1 = zgam1*zgam4 + zgam2*zgam3 za2 = zgam1*zgam3 + zgam2*zgam4 - zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) - zrk2= 2.0 * zrk + zrk = (zgam1 - zgam2) * (zgam1 + zgam2) + if (zrk > eps1) then + zrk = sqrt(zrk) + else + zrk = f_zero + endif + zrk2= zrk + zrk zrp = zrk * cosz zrp1 = f_one + zrp @@ -3982,7 +4017,8 @@ subroutine spcvrtm & ze1r45 = zr4*zexp1 + zr5*zexm1 ! ... collimated beam - if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then +! if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + if ( abs(ze1r45) <= eps1 ) then zrefb(kp) = eps1 ztrab(kp) = zexm2 else @@ -3994,7 +4030,11 @@ subroutine spcvrtm & endif ! ... diffuse beam - zden1 = zr4 / (ze1r45 * zrkg1) + if (ze1r45 >= f_zero) then + zden1 = zr4 / max(eps1, ze1r45*zrkg1) + else + zden1 = zr4 / min(-eps1, ze1r45*zrkg1) + endif zrefd(kp) = max(f_zero, min(f_one, & & zgam2*(zexp1 - zexm1)*zden1 )) ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) From fa43e99778cd225dafcb05db56bd2e49e20b8eeb Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 11 Mar 2021 14:22:13 -0500 Subject: [PATCH 036/165] updating RAS and reverting zorl composite to linear --- physics/GFS_surface_composites.F90 | 16 ++++--- physics/rascnv.F90 | 72 +++++++++++++++--------------- 2 files changed, 46 insertions(+), 42 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index a70675c90..074e5bc4b 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -448,9 +448,9 @@ subroutine GFS_surface_composites_post_run ( txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell txo = max(zero, wfrac-txi) ! txo = open water fraction -! zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) - zorl(i) = txl*log(zorl_lnd(i)) + txi*log(zorl_ice(i)) + txo*log(zorl_wat(i)) - zorl(i) = exp(zorl(i)) + zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) +! zorl(i) = txl*log(zorl_lnd(i)) + txi*log(zorl_ice(i)) + txo*log(zorl_wat(i)) +! zorl(i) = exp(zorl(i)) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) cdq(i) = txl*cdq_lnd(i) + txi*cdq_ice(i) + txo*cdq_wat(i) rb(i) = txl*rb_lnd(i) + txi*rb_ice(i) + txo*rb_wat(i) @@ -627,13 +627,15 @@ subroutine GFS_surface_composites_post_run ( stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * log(zorl_ice(i)) + txo * log(zorl_wat(i)) - zorl(i) = exp(zorl(i)) + zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) +! zorl(i) = txi * log(zorl_ice(i)) + txo * log(zorl_wat(i)) +! zorl(i) = exp(zorl(i)) snowd(i) = txi * snowd_ice(i) endif elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = cice(i)*log(zorl_ice(i)) + (one-cice(i))*log(zorl_wat(i)) - zorl(i) = exp(zorl(i)) + zorl(i) = cice(i)*zorl_ice(i) + (one-cice(i))*zorl_wat(i) +! zorl(i) = cice(i)*log(zorl_ice(i)) + (one-cice(i))*log(zorl_wat(i)) +! zorl(i) = exp(zorl(i)) endif ! if (wet(i)) then diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index 9c47144ac..e78570f34 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -8,7 +8,7 @@ module rascnv implicit none public :: rascnv_init, rascnv_run, rascnv_finalize private - logical, save :: is_initialized = .False. + logical :: is_initialized = .False. ! integer, parameter :: kp = kind_phys integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s @@ -30,9 +30,10 @@ module rascnv &, FOUR_P2=4.0e2_kp, ONE_M10=1.0e-10_kp& &, ONE_M6=1.0e-6_kp, ONE_M5=1.0e-5_kp & &, ONE_M2=1.0e-2_kp, ONE_M1=1.0e-1_kp & - &, oneolog10=one/log(10.0_kp) & - &, facmb = 0.01_kp & ! conversion factor from Pa to hPa (or mb) - &, cmb2pa = 100.0_kp ! Conversion from hPa to Pa + &, oneolog10=one/log(10.0_kp) & + &, rain_min=1.0e-13_kp & + &, facmb=0.01_kp & ! conversion factor from Pa to hPa (or mb) + &, cmb2pa=100.0_kp ! Conversion from hPa to Pa ! ! real (kind=kind_phys), parameter :: frac=0.5_kp, crtmsf=0.0_kp & real (kind=kind_phys), parameter :: frac=0.1_kp, crtmsf=0.0_kp & @@ -70,7 +71,7 @@ module rascnv ! ! For Tilting Angle Specification ! - real(kind=kind_phys), save :: REFP(6), REFR(6), TLAC(8), PLAC(8), & + real(kind=kind_phys) :: REFP(6), REFR(6), TLAC(8), PLAC(8), & TLBPL(7), drdp(5) ! DATA PLAC/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0/ @@ -78,16 +79,16 @@ module rascnv DATA REFP/500.0, 300.0, 250.0, 200.0, 150.0, 100.0/ DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ ! - real(kind=kind_phys), save :: AC(16), AD(16) + real(kind=kind_phys) :: AC(16), AD(16) ! integer, parameter :: nqrp=500001 - real(kind=kind_phys), save :: C1XQRP, C2XQRP, TBQRP(NQRP), & + real(kind=kind_phys) :: C1XQRP, C2XQRP, TBQRP(NQRP), & TBQRA(NQRP), TBQRB(NQRP) ! integer, parameter :: nvtp=10001 - real(kind=kind_phys), save :: C1XVTP, C2XVTP, TBVTP(NVTP) + real(kind=kind_phys) :: C1XVTP, C2XVTP, TBVTP(NVTP) ! - real(kind=kind_phys), save :: afc, facdt, & + real(kind=kind_phys) :: afc, facdt, & grav, cp, alhl, alhf, rgas, rkap, nu, pi, & t0c, rv, cvap, cliq, csol, ttp, eps, epsm1,& ! @@ -96,7 +97,6 @@ module rascnv deg2rad, PIINV, testmboalhl, & rvi, facw, faci, hsub, tmix, DEN - contains ! ----------------------------------------------------------------------- @@ -387,7 +387,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! integer :: nrcmax ! Maximum # of random clouds per 1200s ! Integer KCR, KFX, NCMX, NC, KTEM, I, ii, Lm1, l & - &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & + &, ntrc, ll, km1, kp1, ipt, lv, KBL, n & &, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib & &, kblmn, ksfc, ncrnd real(kind=kind_phys) sgcs(k) @@ -396,8 +396,8 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! real fscav_(ntr+2) ! Fraction scavenged per km ! - fscav_ = zero ! By default no scavenging - if (ntr > 0) then + fscav_ = -999.0_kp ! By default no scavenging + if (ntr > 0 .and. fscav(1) > zero) then do i=1,ntr fscav_(i) = fscav(i) enddo @@ -476,7 +476,6 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & c0i = (psauras(1)*tem1 + psauras(2)*tem2) * tem c0 = (prauras(1)*tem1 + prauras(2)*tem2) * tem if (ccwfac == zero) ccwfac = half - ! ! ctei = .false. ! if (ctei_r(ipt) > ctei_rm) ctei = .true. @@ -511,7 +510,6 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ENDDO krmin = max(krmin,2) -! if (kdt == 1 .and. ipt == 1) write(0,*)' kblmn=',kblmn,kblmx ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 @@ -790,8 +788,6 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & IB = IC(NC) ! cloud top level index if (ib > kbl-1) cycle ! - -! !**************************************************************************** ! if (advtvd) then ! TVD flux limiter scheme for updraft ! l = ib @@ -943,6 +939,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ENDDO ! End of the NC loop! ! RAINC(ipt) = rain * 0.001_kp ! Output rain is in meters + if (rainc(ipt) < rain_min) rainc(ipt) = zero ktop(ipt) = kp1 kbot(ipt) = 0 @@ -1160,9 +1157,9 @@ SUBROUTINE CLOUD( & ! &, HCRITS=2000.0_kp & ! Critical Moist Static Energy for Shallow clouds &, HCRITS=2500.0_kp & ! Critical Moist Static Energy for Shallow clouds &, pcrit_lcl=250.0_kp & ! Critical pressure difference between boundary layer top - ! layer top and lifting condensation level (hPa) -! &, hpert_fac=1.01_kp & ! Perturbation on hbl when ctei=.true. -! &, hpert_fac=1.005_kp & ! Perturbation on hbl when ctei=.true. + ! layer top and lifting condensation level (hPa) +! &, hpert_fac=1.01_kp !& ! Perturbation on hbl when ctei=.true. +! &, hpert_fac=1.005_kp !& ! Perturbation on hbl when ctei=.true. &, qudfac=quad_lam*half & &, shalfac=3.0_kp & ! &, qudfac=quad_lam*pt25, shalfac=3.0_kp !& ! Yogesh's @@ -1462,6 +1459,8 @@ SUBROUTINE CLOUD( & enddo endif +! if (klcl == kd .or. klcl < ktem) return + ! This is to handle mid-level convection from quasi-uniform h if (kmax < kmxb) then @@ -1507,6 +1506,7 @@ SUBROUTINE CLOUD( & ! endif ! if (kbl == kblmx .and. kmax >= km1) kbl = k - 1 !!! + KPBL = KBL ELSE @@ -1515,7 +1515,7 @@ SUBROUTINE CLOUD( & ! KBL = min(kmax,MAX(KBL,KD+2)) KB1 = KBL - 1 -!! +! if (PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd ) then ! & .or. PRL(Kmaxp1)-PRL(KBL) < bldmin) then return @@ -1722,7 +1722,6 @@ SUBROUTINE CLOUD( & qi00 = qi0 ii = 0 777 continue - ! ep_wfn = .false. RNN(KBL) = zero @@ -1784,7 +1783,7 @@ SUBROUTINE CLOUD( & ! clp = one st2 = hbl - hsu - +! if (tx2 == zero) then alm = - st2 / tx1 if (alm > almax) alm = -100.0_kp @@ -1799,6 +1798,7 @@ SUBROUTINE CLOUD( & if (tem1 > almax) tem1 = -100.0_kp if (tem2 > almax) tem2 = -100.0_kp alm = max(tem1,tem2) + endif endif ! @@ -2126,6 +2126,7 @@ SUBROUTINE CLOUD( & ENDDO ENDIF + ! !===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX ! Includes downdraft terms! @@ -2230,6 +2231,7 @@ SUBROUTINE CLOUD( & GMS(K) = GMS(K) + TEM2 GHD(K) = GHD(K) + TEM1 GSD(K) = GSD(K) + TEM2 + ! avh = avh + gmh(K)*(prs(KP1)-prs(K)) ! @@ -2246,7 +2248,6 @@ SUBROUTINE CLOUD( & avh = avh + tx1*(prs(l+1)-prs(l)) ENDDO ! -! !*********************************************************************** !*********************************************************************** @@ -2307,7 +2308,7 @@ SUBROUTINE CLOUD( & ! hbl = hbl * hpert_fac ! qbl = qbl * hpert_fac ! endif - + !*********************************************************************** !===> CLOUD WORKFUNCTION FOR MODIFIED SOUNDING, THEN KERNEL (AKM) @@ -2389,7 +2390,6 @@ SUBROUTINE CLOUD( & AMBMAX = (PRL(KMAXP1)-PRL(KBL))*(FRACBL*GRAVCON) AMB = MAX(MIN(AMB, AMBMAX),ZERO) - !*********************************************************************** !*************************RESULTS*************************************** !*********************************************************************** @@ -2430,8 +2430,9 @@ SUBROUTINE CLOUD( & sigf(kd:k) = one endif - tx1 = max(1.0e-3_kp, abs(gms(kd) * onebcp * sigf(kd))) + tx1 = max(1.0e-6_kp, abs(gms(kd) * onebcp * sigf(kd))) amb = min(tx1*amb, tfrac_max*toi(kd)) / tx1 + ! avt = zero avq = zero @@ -2517,6 +2518,7 @@ SUBROUTINE CLOUD( & ! enddo ! endif +! ! TX1 = zero TX2 = zero @@ -2535,7 +2537,7 @@ SUBROUTINE CLOUD( & clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) cldfrd = clfrac - +! DO L=KD,KBL ! Testing on 20070926 ! for L=KD,K IF (L >= IDH .AND. DDFT) THEN @@ -2597,7 +2599,7 @@ SUBROUTINE CLOUD( & ! ST1 = ST1 * ELOCP - TOI(L) = TOI(L) - ST1 + TOI(L) = TOI(L) - ST1 TCU(L) = TCU(L) - ST1 ENDIF ENDIF @@ -2642,11 +2644,10 @@ SUBROUTINE CLOUD( & HOD(L) = HB ENDIF ENDDO - + DO L=KB1,KD,-1 HCC = HCC + (ETA(L)-ETA(L+1))*HOL(L) ENDDO - ! ! Scavenging -- fscav - fraction scavenged [km-1] ! delz - distance from the entrainment to detrainment layer [km] @@ -2694,7 +2695,7 @@ SUBROUTINE CLOUD( & RCU(L,N) = RCU(L,N) + ST1 st2 = zero endif - + ENDDO ENDDO ! Tracer loop NTRC endif @@ -3466,7 +3467,7 @@ SUBROUTINE DDRFT( & ! VT(1) = GMS(L-1) * QRP(L-1) ** 0.1364 VT(1) = GMS(L-1) * QRPF(QRP(L-1)) RNT = ROR(L-1) * (WVL(L-1)+VT(1))*QRP(L-1) - +! ! TEM = MAX(ALM, 2.5E-4) * MAX(ETA(L), 1.0) TEM = MAX(ALM,ONE_M6) * MAX(ETA(L), ONE) ! TEM = MAX(ALM, 1.0E-5) * MAX(ETA(L), 1.0) @@ -3562,7 +3563,7 @@ SUBROUTINE DDRFT( & TEM2 = TX8 ST1 = zero ENDIF - +! st2 = tx5 TEM = ROR(L)*WVL(L) - ROR(L-1)*WVL(L-1) if (tem > zero) then @@ -3694,7 +3695,7 @@ SUBROUTINE DDRFT( & TEM1 = WVL(L) WVL(L) = VT(2) * (ETD(L-1)*WVL(L-1) - FACG & & * (BUY(L-1)*QRT(L-1)+BUY(L)*QRB(L-1))) -! + ! if (wvl(l) < zero) then ! WVL(L) = max(wvl(l), 0.1*tem1) @@ -3713,6 +3714,7 @@ SUBROUTINE DDRFT( & ! ERRQ = ERRQ + ABS(ERRW/MAX(WVL(L),ONE_M5)) + ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN From cad064986faa53487f260d96429eec825a9b9701 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 2 Apr 2021 14:35:32 -0400 Subject: [PATCH 037/165] adding debug --- physics/debug/GFS_MP_generic.F90_dbg | 403 ++++ physics/debug/GFS_MP_generic.meta_dbg | 905 ++++++++ physics/debug/GFS_suite_interstitial.F90_dbg | 850 +++++++ physics/debug/GFS_suite_interstitial.meta_dbg | 2014 +++++++++++++++++ physics/debug/GFS_surface_composites.F90_dbg | 689 ++++++ physics/debug/GFS_surface_composites.meta_dbg | 1928 ++++++++++++++++ physics/debug/GFS_surface_generic.F90_dbg | 400 ++++ physics/debug/GFS_surface_generic.meta_dbg | 1354 +++++++++++ physics/debug/sfc_diff.f_dbg | 779 +++++++ physics/debug/sfc_diff.meta_dbg | 653 ++++++ physics/debug/sfc_drv.f_dbg | 666 ++++++ physics/debug/sfc_drv.meta_dbg | 788 +++++++ 12 files changed, 11429 insertions(+) create mode 100644 physics/debug/GFS_MP_generic.F90_dbg create mode 100644 physics/debug/GFS_MP_generic.meta_dbg create mode 100644 physics/debug/GFS_suite_interstitial.F90_dbg create mode 100644 physics/debug/GFS_suite_interstitial.meta_dbg create mode 100644 physics/debug/GFS_surface_composites.F90_dbg create mode 100644 physics/debug/GFS_surface_composites.meta_dbg create mode 100644 physics/debug/GFS_surface_generic.F90_dbg create mode 100644 physics/debug/GFS_surface_generic.meta_dbg create mode 100644 physics/debug/sfc_diff.f_dbg create mode 100644 physics/debug/sfc_diff.meta_dbg create mode 100644 physics/debug/sfc_drv.f_dbg create mode 100644 physics/debug/sfc_drv.meta_dbg diff --git a/physics/debug/GFS_MP_generic.F90_dbg b/physics/debug/GFS_MP_generic.F90_dbg new file mode 100644 index 000000000..d2ffbe8c5 --- /dev/null +++ b/physics/debug/GFS_MP_generic.F90_dbg @@ -0,0 +1,403 @@ +!> \file GFS_MP_generic.F90 +!! This file contains the subroutines that calculate diagnotics variables +!! before/after calling any microphysics scheme: + +!> This module contains the CCPP-compliant MP generic pre interstitial codes. + module GFS_MP_generic_pre + contains + + subroutine GFS_MP_generic_pre_init() + end subroutine GFS_MP_generic_pre_init + +!> \section arg_table_GFS_MP_generic_pre_run Argument Table +!! \htmlinclude GFS_MP_generic_pre_run.html +!! + subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, ntrac, gt0, gq0, save_t, save_qv, save_q, errmsg, errflg) +! + use machine, only: kind_phys + + implicit none + integer, intent(in) :: im, levs, ntcw, nncl, ntrac + logical, intent(in) :: ldiag3d, qdiag3d, do_aw + real(kind=kind_phys), dimension(im, levs), intent(in) :: gt0 + real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 + + real(kind=kind_phys), dimension(im, levs), intent(inout) :: save_t, save_qv + real(kind=kind_phys), dimension(im, levs, ntrac), intent(inout) :: save_q + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ldiag3d .or. do_aw) then + do k=1,levs + do i=1,im + save_t(i,k) = gt0(i,k) + enddo + enddo + if(qdiag3d) then + do k=1,levs + do i=1,im + ! Here, gq0(...,1) is used instead of gq0_water_vapor + ! to be consistent with the GFS_MP_generic_post_run + ! code. + save_qv(i,k) = gq0(i,k,1) + enddo + enddo + endif + if(do_aw) then + save_q(1:im,:,1) = gq0(1:im,:,1) + do n=ntcw,ntcw+nncl-1 + save_q(1:im,:,n) = gq0(1:im,:,n) + enddo + endif + endif + + end subroutine GFS_MP_generic_pre_run + + subroutine GFS_MP_generic_pre_finalize() + end subroutine GFS_MP_generic_pre_finalize + + end module GFS_MP_generic_pre + +!> This module contains the subroutine that calculates +!! precipitation type and its post, which provides precipitation forcing +!! to LSM. + module GFS_MP_generic_post + contains + + subroutine GFS_MP_generic_post_init() + end subroutine GFS_MP_generic_post_init + +!>\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. +!! +!! \section arg_table_GFS_MP_generic_post_run Argument Table +!! \htmlinclude GFS_MP_generic_post_run.html +!! +!> \section gfs_mp_gen GFS MP Generic Post General Algorithm +!> @{ + subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & + imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, con_g, dtf, frain, rainc, rain1, & + rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, rain0, ice0, snow0, & + graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & + totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & + drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & + graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, lprnt, ipr, errmsg, errflg) +! + use machine, only: kind_phys + + implicit none + + integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, ipr + integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires + logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, lprnt + + real(kind=kind_phys), intent(in) :: dtf, frain, con_g + real(kind=kind_phys), dimension(im), intent(in) :: rain1, xlat, xlon, tsfc + real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel, rainc + real(kind=kind_phys), dimension(im), intent(in) :: rain0, ice0, snow0, graupel0 + real(kind=kind_phys), dimension(im,nrcm), intent(in) :: rann + real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, prsl, save_t, save_qv, del + real(kind=kind_phys), dimension(im,levs+1), intent(in) :: prsi, phii + real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: gq0 + + real(kind=kind_phys), dimension(im), intent(in ) :: sr + real(kind=kind_phys), dimension(im), intent(inout) :: rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, & + srflag, cnvprcp, totprcp, totice, totsnw, totgrp, cnvprcpb, & + totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, & + snow_cpl, pwat + + real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt ! only if ldiag3d + real(kind=kind_phys), dimension(:,:), intent(inout) :: dq3dt ! only if ldiag3d and qdiag3d + + ! Stochastic physics / surface perturbations + real(kind=kind_phys), dimension(im), intent(inout) :: drain_cpl + real(kind=kind_phys), dimension(im), intent(inout) :: dsnow_cpl + + ! Rainfall variables previous time step + integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp + real(kind=kind_phys), dimension(im), intent(inout) :: raincprv + real(kind=kind_phys), dimension(im), intent(inout) :: rainncprv + real(kind=kind_phys), dimension(im), intent(inout) :: iceprv + real(kind=kind_phys), dimension(im), intent(inout) :: snowprv + real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv + real(kind=kind_phys), dimension(im), intent(inout) :: draincprv + real(kind=kind_phys), dimension(im), intent(inout) :: drainncprv + real(kind=kind_phys), dimension(im), intent(inout) :: diceprv + real(kind=kind_phys), dimension(im), intent(inout) :: dsnowprv + real(kind=kind_phys), dimension(im), intent(inout) :: dgraupelprv + + real(kind=kind_phys), intent(in) :: dtp + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! DH* TODO: CLEANUP, all of these should be coming in through the argument list + real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys + real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys + real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys + real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys + ! *DH + + integer :: i, k, ic + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 + real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + onebg = one/con_g + + do i = 1, im + rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit + enddo + +!> - If requested (e.g. Zhao-Carr MP scheme), call calpreciptype() to calculate dominant +!! precipitation type. + ! DH* TODO - Fix wrong code in non-CCPP build (GFS_physics_driver) + ! and use commented lines here (keep wrong version for bit-for-bit): + ! put ice, snow, graupel on dynamics timestep. The way the code in + ! GFS_physics_driver is written, Diag%{graupel,ice,snow} are on the + ! physics timestep, while Diag%{rain,rainc} and all totprecip etc + ! are on the dynamics timestep. Confusing, but works if frain=1. *DH + if (imp_physics == imp_physics_gfdl) then + tprcp = max(zero, rain) ! clu: rain -> tprcp + !graupel = frain*graupel0 + !ice = frain*ice0 + !snow = frain*snow0 + graupel = graupel0 + ice = ice0 + snow = snow0 + ! Do it right from the beginning for Thompson + else if (imp_physics == imp_physics_thompson) then + tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip + graupel = frain*graupel0 ! time-step graupel + ice = frain*ice0 ! time-step ice + snow = frain*snow0 ! time-step snow + + else if (imp_physics == imp_physics_fer_hires) then + tprcp = max (zero, rain) ! time-step convective and explicit precip + ice = frain*rain1*sr ! time-step ice + end if + + if (lsm==lsm_ruc .or. lsm==lsm_noahmp) then + raincprv(:) = rainc(:) + rainncprv(:) = frain * rain1(:) + iceprv(:) = ice(:) + snowprv(:) = snow(:) + graupelprv(:) = graupel(:) + !for NoahMP, calculate precipitation rates from liquid water equivalent thickness for use in next time step + !Note (GJF): Precipitation LWE thicknesses are multiplied by the frain factor, and are thus on the dynamics time step, but the conversion as written + ! (with dtp in the denominator) assumes the rate is calculated on the physics time step. This only works as expected when dtf=dtp (i.e. when frain=1). + if (lsm == lsm_noahmp) then + tem = one / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? + draincprv(:) = tem * raincprv(:) + drainncprv(:) = tem * rainncprv(:) + dsnowprv(:) = tem * snowprv(:) + dgraupelprv(:) = tem * graupelprv(:) + diceprv(:) = tem * iceprv(:) + end if + end if + + if (cal_pre) then ! hchuang: add dominant precipitation type algorithm +! + call calpreciptype (kdt, nrcm, im, im, levs, levs+1, & + rann, xlat, xlon, gt0, & + gq0(:,:,1), prsl, prsi, & + rain, phii, tsfc, & ! input + domr, domzr, domip, doms) ! output +! +! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation + + if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then + do i=1,im + tprcp(i) = max(zero, rain(i) ) + if(doms(i) > zero .or. domip(i) > zero) then + srflag(i) = one + else + srflag(i) = zero + end if + enddo + endif + if (lssav) then + do i=1,im + domr_diag(i) = domr_diag(i) + domr(i) * dtf + domzr_diag(i) = domzr_diag(i) + domzr(i) * dtf + domip_diag(i) = domip_diag(i) + domip(i) * dtf + doms_diag(i) = doms_diag(i) + doms(i) * dtf + enddo + endif + + endif + + t850(1:im) = gt0(1:im,1) + + do k = 1, levs-1 + do i = 1, im + if (prsl(i,k) > p850 .and. prsl(i,k+1) <= p850) then + t850(i) = gt0(i,k) - (prsl(i,k)-p850) / & + (prsl(i,k)-prsl(i,k+1)) * & + (gt0(i,k)-gt0(i,k+1)) + endif + enddo + enddo + + ! Conversion factor from mm per day to m per physics timestep + tem = dtp * con_p001 / con_day + +!> - For GFDL and Thompson MP scheme, determine convective snow by surface temperature; +!! and determine explicit rain/snow by snow/ice/graupel coming out directly from MP +!! and convective rainfall from the cumulus scheme if the surface temperature is below +!! \f$0^oC\f$. + + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + +! determine convective rain/snow by surface temperature +! determine large-scale rain/snow by rain/snow coming out directly from MP + + if (lsm /= lsm_ruc) then + do i = 1, im + !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 + srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) + if (tsfc(i) >= 273.15_kind_phys) then + crain = rainc(i) + csnow = zero + else + crain = zero + csnow = rainc(i) + endif +! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then +! if (snow0(i)+ice0(i)+graupel0(i)+csnow > 0.0) then +! Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) +! endif + total_precip = snow0(i)+ice0(i)+graupel0(i)+rain0(i)+rainc(i) + if (total_precip > rainmin) then + srflag(i) = (snow0(i)+ice0(i)+graupel0(i)+csnow)/total_precip + endif + enddo + else + ! only for RUC LSM + do i=1,im + srflag(i) = sr(i) + enddo + endif ! lsm==lsm_ruc + elseif( .not. cal_pre) then + if (imp_physics == imp_physics_mg) then ! MG microphysics + do i=1,im + if (rain(i) > rainmin) then + tem1 = max(zero, (rain(i)-rainc(i))) * sr(i) + tem2 = one / rain(i) + if (t850(i) > 273.16_kind_phys) then + srflag(i) = max(zero, min(one, tem1*tem2)) + else + srflag(i) = max(zero, min(one, (tem1+rainc(i))*tem2)) + endif + else + srflag(i) = zero + rain(i) = zero + rainc(i) = zero + endif + tprcp(i) = max(zero, rain(i)) + enddo + else ! not GFDL or MG or Thompson microphysics + do i = 1, im + tprcp(i) = max(zero, rain(i)) + srflag(i) = sr(i) + enddo + endif + endif + + if (lssav) then +! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & +! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & +! 'rain=',Diag%rain(1) + do i=1,im + cnvprcp (i) = cnvprcp (i) + rainc(i) + totprcp (i) = totprcp (i) + rain(i) + totice (i) = totice (i) + ice(i) + totsnw (i) = totsnw (i) + snow(i) + totgrp (i) = totgrp (i) + graupel(i) + + cnvprcpb(i) = cnvprcpb(i) + rainc(i) + totprcpb(i) = totprcpb(i) + rain(i) + toticeb (i) = toticeb (i) + ice(i) + totsnwb (i) = totsnwb (i) + snow(i) + totgrpb (i) = totgrpb (i) + graupel(i) + enddo + + if (ldiag3d) then + do k=1,levs + do i=1,im + dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain + enddo + enddo + if (qdiag3d) then + do k=1,levs + do i=1,im + dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain + enddo + enddo + endif + endif + endif + + if (cplflx .or. cplchm) then + do i = 1, im + dsnow_cpl(i)= max(zero, rain(i) * srflag(i)) + drain_cpl(i)= max(zero, rain(i) - dsnow_cpl(i)) + rain_cpl(i) = rain_cpl(i) + drain_cpl(i) + snow_cpl(i) = snow_cpl(i) + dsnow_cpl(i) + enddo + endif + + if (cplchm) then + do i = 1, im + rainc_cpl(i) = rainc_cpl(i) + rainc(i) + enddo + endif + + pwat(:) = zero + do k = 1, levs + do i=1, im + work1(i) = zero + enddo + if (ncld > 0) then + do ic = ntcw, ntcw+nncl-1 + do i=1,im + work1(i) = work1(i) + gq0(i,k,ic) + enddo + enddo + endif + do i=1,im + pwat(i) = pwat(i) + del(i,k)*(gq0(i,k,1)+work1(i)) + enddo + enddo + do i=1,im + pwat(i) = pwat(i) * onebg + enddo + + if (lprnt) then + write(0,*)' end mp gt0=',gt0(ipr,:),' kdt=',kdt + write(0,*)' end mp gq0=',gq0(ipr,:,1),' kdt=',kdt + endif + + + end subroutine GFS_MP_generic_post_run +!> @} + + subroutine GFS_MP_generic_post_finalize() + end subroutine GFS_MP_generic_post_finalize + + end module GFS_MP_generic_post diff --git a/physics/debug/GFS_MP_generic.meta_dbg b/physics/debug/GFS_MP_generic.meta_dbg new file mode 100644 index 000000000..dee5cb074 --- /dev/null +++ b/physics/debug/GFS_MP_generic.meta_dbg @@ -0,0 +1,905 @@ +[ccpp-table-properties] + name = GFS_MP_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_MP_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = logical flag for 3D diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = logical flag for 3D tracer diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_aw] + standard_name = flag_for_Arakawa_Wu_adjustment + long_name = flag for Arakawa Wu scale-aware adjustment + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[nncl] + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[gt0] + standard_name = air_temperature_updated_by_physics + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[save_qv] + standard_name = water_vapor_specific_humidity_save + long_name = water vapor specific humidity before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[save_q] + standard_name = tracer_concentration_save + long_name = tracer concentration before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_MP_generic_post + type = scheme + dependencies = calpreciptype.f90,machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_MP_generic_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current time step index + units = index + dimensions = () + type = integer + intent = in + optional = F +[nrcm] + standard_name = array_dimension_of_random_number + long_name = second dimension of random number stream for RAS + units = count + dimensions = () + type = integer + intent = in + optional = F +[ncld] + standard_name = number_of_hydrometeors + long_name = choice of cloud scheme / number of hydrometeors + units = count + dimensions = () + type = integer + intent = in + optional = F +[nncl] + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_gfdl] + standard_name = flag_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_thompson] + standard_name = flag_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_mg] + standard_name = flag_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_fer_hires] + standard_name = flag_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[cal_pre] + standard_name = flag_for_precipitation_type_algorithm + long_name = flag controls precip type algorithm + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = logical flag for 3D tracer diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[frain] + standard_name = dynamics_to_physics_timestep_ratio + long_name = ratio of dynamics timestep to physics timestep + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rainc] + standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep + long_name = convective rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rain1] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit rainfall amount on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rann] + standard_name = random_number_array + long_name = random number array (0-1) + units = none + dimensions = (horizontal_loop_extent,array_dimension_of_random_number) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gt0] + standard_name = air_temperature_updated_by_physics + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = layer mean pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = pressure at layer interface + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ice] + standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep + long_name = ice fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snow] + standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep + long_name = snow fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[graupel] + standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep + long_name = graupel fall at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[save_t] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[save_qv] + standard_name = water_vapor_specific_humidity_save + long_name = water vapor specific humidity before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rain0] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ice0] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snow0] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[graupel0] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between midlayers + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[domr_diag] + standard_name = dominant_rain_type + long_name = dominant rain type + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[domzr_diag] + standard_name = dominant_freezing_rain_type + long_name = dominant freezing rain type + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[domip_diag] + standard_name = dominant_sleet_type + long_name = dominant sleet type + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[doms_diag] + standard_name = dominant_snow_type + long_name = dominant snow type + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total precipitation amount in each time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = snow/rain flag for precipitation + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = snow ratio: ratio of snow to total precipitation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cnvprcp] + standard_name = cumulative_lwe_thickness_of_convective_precipitation_amount + long_name = cumulative convective precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totprcp] + standard_name = accumulated_lwe_thickness_of_precipitation_amount + long_name = accumulated total precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totice] + standard_name = accumulated_lwe_thickness_of_ice_amount + long_name = accumulated ice precipitation + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totsnw] + standard_name = accumulated_lwe_thickness_of_snow_amount + long_name = accumulated snow precipitation + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totgrp] + standard_name = accumulated_lwe_thickness_of_graupel_amount + long_name = accumulated graupel precipitation + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cnvprcpb] + standard_name = cumulative_lwe_thickness_of_convective_precipitation_amount_in_bucket + long_name = cumulative convective precipitation in bucket + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totprcpb] + standard_name = accumulated_lwe_thickness_of_precipitation_amount_in_bucket + long_name = accumulated total precipitation in bucket + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[toticeb] + standard_name = accumulated_lwe_thickness_of_ice_amount_in_bucket + long_name = accumulated ice precipitation in bucket + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totsnwb] + standard_name = accumulated_lwe_thickness_of_snow_amount_in_bucket + long_name = accumulated snow precipitation in bucket + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[totgrpb] + standard_name = accumulated_lwe_thickness_of_graupel_amount_in_bucket + long_name = accumulated graupel precipitation in bucket + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt] + standard_name = cumulative_change_in_temperature_due_to_microphysics + long_name = cumulative change in temperature due to microphysics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dq3dt] + standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_microphysics + long_name = cumulative change in water vapor specific humidity due to microphysics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_for_coupling + long_name = total rain precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rainc_cpl] + standard_name = lwe_thickness_of_convective_precipitation_amount_for_coupling + long_name = total convective precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snow_cpl] + standard_name = lwe_thickness_of_snow_amount_for_coupling + long_name = total snow precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[pwat] + standard_name = column_precipitable_water + long_name = precipitable water + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drain_cpl] + standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling + long_name = change in rain_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dsnow_cpl] + standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling + long_name = change in show_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[lsm] + standard_name = flag_for_land_surface_scheme + long_name = flag for land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_ruc] + standard_name = flag_for_ruc_land_surface_scheme + long_name = flag for RUC land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[lsm_noahmp] + standard_name = flag_for_noahmp_land_surface_scheme + long_name = flag for NOAH MP land surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[raincprv] + standard_name = lwe_thickness_of_convective_precipitation_amount_from_previous_timestep + long_name = convective_precipitation_amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rainncprv] + standard_name = lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep + long_name = explicit rainfall from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[iceprv] + standard_name = lwe_thickness_of_ice_amount_from_previous_timestep + long_name = ice amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowprv] + standard_name = lwe_thickness_of_snow_amount_from_previous_timestep + long_name = snow amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[graupelprv] + standard_name = lwe_thickness_of_graupel_amount_from_previous_timestep + long_name = graupel amount from previous timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[draincprv] + standard_name = convective_precipitation_rate_from_previous_timestep + long_name = convective precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drainncprv] + standard_name = explicit_rainfall_rate_from_previous_timestep + long_name = explicit rainfall rate previous timestep + units = mm s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[diceprv] + standard_name = ice_precipitation_rate_from_previous_timestep + long_name = ice precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dsnowprv] + standard_name = snow_precipitation_rate_from_previous_timestep + long_name = snow precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dgraupelprv] + standard_name = graupel_precipitation_rate_from_previous_timestep + long_name = graupel precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + diff --git a/physics/debug/GFS_suite_interstitial.F90_dbg b/physics/debug/GFS_suite_interstitial.F90_dbg new file mode 100644 index 000000000..ecca10133 --- /dev/null +++ b/physics/debug/GFS_suite_interstitial.F90_dbg @@ -0,0 +1,850 @@ +!> \file GFS_suite_interstitial.f90 +!! Contains code related to more than one scheme in the GFS physics suite. + + module GFS_suite_interstitial_rad_reset + + contains + + subroutine GFS_suite_interstitial_rad_reset_init () + end subroutine GFS_suite_interstitial_rad_reset_init + + subroutine GFS_suite_interstitial_rad_reset_finalize() + end subroutine GFS_suite_interstitial_rad_reset_finalize + +!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html +!! + subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in) :: Model + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%rad_reset(Model) + + end subroutine GFS_suite_interstitial_rad_reset_run + + end module GFS_suite_interstitial_rad_reset + + + module GFS_suite_interstitial_phys_reset + + contains + + subroutine GFS_suite_interstitial_phys_reset_init () + end subroutine GFS_suite_interstitial_phys_reset_init + + subroutine GFS_suite_interstitial_phys_reset_finalize() + end subroutine GFS_suite_interstitial_phys_reset_finalize + +!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table +!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html +!! + subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type + + implicit none + + ! interface variables + type(GFS_interstitial_type), intent(inout) :: Interstitial + type(GFS_control_type), intent(in) :: Model + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + call Interstitial%phys_reset(Model) + + end subroutine GFS_suite_interstitial_phys_reset_run + + end module GFS_suite_interstitial_phys_reset + + + module GFS_suite_interstitial_1 + + contains + + subroutine GFS_suite_interstitial_1_init () + end subroutine GFS_suite_interstitial_1_init + + subroutine GFS_suite_interstitial_1_finalize() + end subroutine GFS_suite_interstitial_1_finalize + +!> \section arg_table_GFS_suite_interstitial_1_run Argument Table +!! \htmlinclude GFS_suite_interstitial_1_run.html +!! + subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & + islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in) :: im, levs, ntrac + real(kind=kind_phys), intent(in) :: dtf, dtp, dxmin, dxinv + real(kind=kind_phys), intent(in), dimension(im) :: slmsk, area, pgr + + integer, intent(out), dimension(im) :: islmsk + real(kind=kind_phys), intent(out), dimension(im) :: work1, work2, psurf + real(kind=kind_phys), intent(out), dimension(im,levs) :: dudt, dvdt, dtdt + real(kind=kind_phys), intent(out), dimension(im,levs,ntrac) :: dqdt + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i, k, n + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i = 1, im + islmsk(i) = nint(slmsk(i)) + + work1(i) = (log(area(i)) - dxmin) * dxinv + work1(i) = max(zero, min(one, work1(i))) + work2(i) = one - work1(i) + psurf(i) = pgr(i) + end do + + do k=1,levs + do i=1,im + dudt(i,k) = zero + dvdt(i,k) = zero + dtdt(i,k) = zero + enddo + enddo + do n=1,ntrac + do k=1,levs + do i=1,im + dqdt(i,k,n) = zero + enddo + enddo + enddo + + end subroutine GFS_suite_interstitial_1_run + + end module GFS_suite_interstitial_1 + + + module GFS_suite_interstitial_2 + + use machine, only: kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + logical :: linit_mod = .false. + + contains + + subroutine GFS_suite_interstitial_2_init () + end subroutine GFS_suite_interstitial_2_init + + subroutine GFS_suite_interstitial_2_finalize() + end subroutine GFS_suite_interstitial_2_finalize +#if 0 +!> \section arg_table_GFS_suite_interstitial_2_run Argument Table +!! \htmlinclude GFS_suite_interstitial_2_run.html +!! +#endif + subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplflx, flag_cice, shal_cnv, old_monin, mstrat, & + do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & + work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & + adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & + ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, lprnt, ipr, kdt, errmsg, errflg) + + implicit none + + ! interface variables + integer, intent(in ) :: im, levs, imfshalcnv, ipr, kdt + logical, intent(in ) :: lssav, ldiag3d, lsidea, cplflx, shal_cnv, lprnt + logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian + real(kind=kind_phys), intent(in ) :: dtf, cp, hvap + + logical, intent(in ), dimension(im) :: flag_cice + real(kind=kind_phys), intent(in ), dimension(2) :: ctei_rm + real(kind=kind_phys), intent(in ), dimension(im) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, ulwsfc_cice, work1, work2 + real(kind=kind_phys), intent(in ), dimension(im) :: cice + real(kind=kind_phys), intent(in ), dimension(im, levs) :: htrsw, htrlw, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk + real(kind=kind_phys), intent(in ), dimension(im, levs+1) :: prsi + real(kind=kind_phys), intent(in ), dimension(im, levs, 6) :: lwhd + integer, intent(inout), dimension(im) :: kinver + real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r + real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat + real(kind=kind_phys), intent(inout), dimension(im) :: adjsfculw + + ! These arrays are only allocated if ldiag3d is .true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp + + logical, intent(in ), dimension(im) :: dry, icy, wet + real(kind=kind_phys), intent(in ), dimension(im) :: frland + real(kind=kind_phys), intent(in ) :: huge + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) + integer :: i, k + real(kind=kind_phys) :: tem1, tem2, tem, hocp + logical, dimension(im) :: invrsn + real(kind=kind_phys), dimension(im) :: tx1, tx2 + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + hocp = hvap/cp + + if (lprnt) then + write(0,*)' tgrs=',tgrs(ipr,:),' kdt=',kdt + write(0,*)' qgrs=',qgrs_water_vapor(ipr,:),' kdt=',kdt + endif + + if (lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0_kind_phys ) then + suntim(i) = suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + if (.not. use_LW_jacobian) then + if (frac_grid) then + do i=1,im + tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell + if (flag_cice(i)) then + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + else + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + endif + enddo + else + do i=1,im + if (dry(i)) then ! all land + adjsfculw(i) = adjsfculw_lnd(i) + elseif (icy(i)) then ! ice (and water) + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif + else + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif + endif + else ! all water + adjsfculw(i) = adjsfculw_wat(i) + endif + enddo + endif + endif + + do i=1,im + dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf + ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf + psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure + enddo + + if (ldiag3d) then + if (lsidea) then + do k=1,levs + do i=1,im + dt3dt_lw(i,k) = dt3dt_lw(i,k) + lwhd(i,k,1)*dtf + dt3dt_sw(i,k) = dt3dt_sw(i,k) + lwhd(i,k,2)*dtf + dt3dt_pbl(i,k) = dt3dt_pbl(i,k) + lwhd(i,k,3)*dtf + dt3dt_dcnv(i,k) = dt3dt_dcnv(i,k) + lwhd(i,k,4)*dtf + dt3dt_scnv(i,k) = dt3dt_scnv(i,k) + lwhd(i,k,5)*dtf + dt3dt_mp(i,k) = dt3dt_mp(i,k) + lwhd(i,k,6)*dtf + enddo + enddo + else + do k=1,levs + do i=1,im + dt3dt_lw(i,k) = dt3dt_lw(i,k) + htrlw(i,k)*dtf + dt3dt_sw(i,k) = dt3dt_sw(i,k) + htrsw(i,k)*dtf*xmu(i) + enddo + enddo + endif + endif + endif ! end if_lssav_block + + do i=1, im + invrsn(i) = .false. + tx1(i) = zero + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys + enddo + + if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & + .or. do_shoc) then + ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) + do k=1,levs/2 + do i=1,im + if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (tgrs(i,k+1) - tgrs(i,k)) & + / (prsl(i,k) - prsl(i,k+1)) + + if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & + ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then + invrsn(i) = .true. + + if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then + tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) + tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) + + tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) + else + ctei_r(i) = 10.0_kind_phys + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + + end subroutine GFS_suite_interstitial_2_run + + end module GFS_suite_interstitial_2 + + + module GFS_suite_stateout_reset + + contains + + subroutine GFS_suite_stateout_reset_init () + end subroutine GFS_suite_stateout_reset_init + + subroutine GFS_suite_stateout_reset_finalize() + end subroutine GFS_suite_stateout_reset_finalize + +!> \section arg_table_GFS_suite_stateout_reset_run Argument Table +!! \htmlinclude GFS_suite_stateout_reset_run.html +!! + subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & + tgrs, ugrs, vgrs, qgrs, & + gt0 , gu0 , gv0 , gq0 , & + errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in) :: im + integer, intent(in) :: levs + integer, intent(in) :: ntrac + real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs, ugrs, vgrs + real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: qgrs + real(kind=kind_phys), dimension(im,levs), intent(out) :: gt0, gu0, gv0 + real(kind=kind_phys), dimension(im,levs,ntrac), intent(out) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + gu0(:,:) = ugrs(:,:) + gv0(:,:) = vgrs(:,:) + gq0(:,:,:) = qgrs(:,:,:) + + end subroutine GFS_suite_stateout_reset_run + + end module GFS_suite_stateout_reset + + + module GFS_suite_stateout_update + + contains + + subroutine GFS_suite_stateout_update_init () + end subroutine GFS_suite_stateout_update_init + + subroutine GFS_suite_stateout_update_finalize() + end subroutine GFS_suite_stateout_update_finalize + +!> \section arg_table_GFS_suite_stateout_update_run Argument Table +!! \htmlinclude GFS_suite_stateout_update_run.html +!! + subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & + tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & + gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & + imp_physics_fer_hires, epsq, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in) :: im + integer, intent(in) :: levs + integer, intent(in) :: ntrac + integer, intent(in) :: imp_physics,imp_physics_fer_hires + integer, intent(in) :: ntiw, nqrimef + real(kind=kind_phys), intent(in) :: dtp, epsq + + real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs, ugrs, vgrs + real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: qgrs + real(kind=kind_phys), dimension(im,levs), intent(in) :: dudt, dvdt, dtdt + real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: dqdt + real(kind=kind_phys), dimension(im,levs), intent(out) :: gt0, gu0, gv0 + real(kind=kind_phys), dimension(im,levs,ntrac), intent(out) :: gq0 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp + gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp + gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp + gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp + + if (imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + if(gq0(i,k,ntiw) > epsq) then + gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) + else + gq0(i,k,nqrimef) = 1. + end if + end do + end do + end if + + end subroutine GFS_suite_stateout_update_run + + end module GFS_suite_stateout_update + + + module GFS_suite_interstitial_3 + + contains + + subroutine GFS_suite_interstitial_3_init () + end subroutine GFS_suite_interstitial_3_init + + subroutine GFS_suite_interstitial_3_finalize() + end subroutine GFS_suite_interstitial_3_finalize + +#if 0 +!> \section arg_table_GFS_suite_interstitial_3_run Argument Table +!! \htmlinclude GFS_suite_interstitial_3_run.html +!! +#endif + subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & + satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & + ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & + xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, & + imp_physics_wsm6, imp_physics_fer_hires, prsi, & + prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & + work1, work2, kpbl, kinver, ras, me, & + clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & + imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, me + integer, dimension(im), intent(in) :: islmsk, kpbl, kinver + logical, intent(in) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras + + real(kind=kind_phys), intent(in) :: rhcbot, rhcmax, rhcpbl, rhctop + real(kind=kind_phys), dimension(im), intent(in) :: work1, work2 + real(kind=kind_phys), dimension(im, levs), intent(in) :: prsl, prslk + real(kind=kind_phys), dimension(im, levs+1), intent(in) :: prsi + real(kind=kind_phys), dimension(im), intent(in) :: xlon, xlat + real(kind=kind_phys), dimension(im, levs), intent(in) :: gt0 + real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 + + real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(inout) :: save_qi + real(kind=kind_phys), dimension(:, :), intent(inout) :: save_tcp ! ONLY ALLOCATE FOR THOMPSON! TODO + real(kind=kind_phys), dimension(im, levs, nn), intent(inout) :: clw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i,k,n,tracers,kk + real(kind=kind_phys) :: tem, tem1, tem2 + real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 + + !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & + ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 + ! in the following inverse of slope_mg and slope_upmg are specified + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & + slope_upmg = 25.0_kind_phys + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (cscnv .or. satmedmf .or. trans_trac .or. ras) then + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then + tracers = tracers + 1 + do k=1,levs + do i=1,im + clw(i,k,tracers) = gq0(i,k,n) + enddo + enddo + endif + enddo + endif ! end if_ras or cfscnv or samf + + if (ntcw > 0) then + if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf + do i=1,im + tx1(i) = one / prsi(i,1) + tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) + + kk = min(kinver(i), max(2,kpbl(i))) + tx3(i) = prsi(i,kk)*tx1(i) + tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) + enddo + do k = 1, levs + do i = 1, im + tem = prsl(i,k) * tx1(i) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) + ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 + ! and rhcbot represents pbl top critical relative humidity + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning + if (islmsk(i) > 0) then + tem1 = one / (one+exp(tem1+tem1)) + else + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) + endif + tem2 = one / (one+exp(tem2)) + + rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) + enddo + enddo + else + do k=1,levs + do i=1,im + kk = max(10,kpbl(i)) + if (k < kk) then + tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) + else + tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) + endif + tem = rhcmax * work1(i) + tem * work2(i) + rhc(i,k) = max(zero, min(one,tem)) + enddo + enddo + endif + else + rhc(:,:) = 1.0 + endif + + if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics + !GF* move to GFS_MP_generic_pre (from gscond/precpd) + ! do i=1,im + ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) + ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) + ! enddo + !*GF + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntcw) + enddo + enddo + elseif (imp_physics == imp_physics_gfdl) then + clw(1:im,:,1) = gq0(1:im,:,ntcw) + elseif (imp_physics == imp_physics_thompson) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + save_tcp(i,k) = gt0(i,k) + enddo + enddo + if(ltaerosol) then + save_qi(:,:) = clw(:,:,1) + save_qc(:,:) = clw(:,:,2) + else + save_qi(:,:) = clw(:,:,1) + endif + elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + endif + + end subroutine GFS_suite_interstitial_3_run + + end module GFS_suite_interstitial_3 + + module GFS_suite_interstitial_4 + + contains + + subroutine GFS_suite_interstitial_4_init () + end subroutine GFS_suite_interstitial_4_init + + subroutine GFS_suite_interstitial_4_finalize() + end subroutine GFS_suite_interstitial_4_finalize + +!> \section arg_table_GFS_suite_interstitial_4_run Argument Table +!! \htmlinclude GFS_suite_interstitial_4_run.html +!! + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, dtf, save_qc, save_qi, con_pi, & + gq0, clw, prsl, save_tcp, con_rd, nwfa, spechum, dqdti, errmsg, errflg) + + use machine, only: kind_phys + use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + + implicit none + + ! interface variables + + integer, intent(in) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & + ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf + + logical, intent(in) :: ltaerosol, cplchm + + real(kind=kind_phys), intent(in) :: con_pi, dtf + real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc + ! save_qi is not allocated for Zhao-Carr MP + real(kind=kind_phys), dimension(:, :), intent(in) :: save_qi + + real(kind=kind_phys), dimension(im,levs,ntrac), intent(inout) :: gq0 + real(kind=kind_phys), dimension(im,levs,nn), intent(inout) :: clw + real(kind=kind_phys), dimension(im,levs), intent(in) :: prsl + real(kind=kind_phys), intent(in) :: con_rd + real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp + real(kind=kind_phys), dimension(im,levs), intent(in) :: spechum + + ! dqdti may not be allocated + real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i,k,n,tracers + + real(kind=kind_phys), dimension(im,levs) :: rho_dryair + real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) + real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! --- update the tracers due to deep & shallow cumulus convective transport +! (except for suspended water and ice) + + if (tracers_total > 0) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then + tracers = tracers + 1 + do k=1,levs + do i=1,im + gq0(i,k,n) = clw(i,k,tracers) + enddo + enddo + endif + enddo + endif + + if (ntcw > 0) then + +! for microphysics + if (imp_physics == imp_physics_zhao_carr .or. & + imp_physics == imp_physics_zhao_carr_pdf .or. & + imp_physics == imp_physics_gfdl) then + gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) + + elseif (ntiw > 0) then + do k=1,levs + do i=1,im + gq0(i,k,ntiw) = clw(i,k,1) ! ice + gq0(i,k,ntcw) = clw(i,k,2) ! water + enddo + enddo + + if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then + do k=1,levs + do i=1,im + !> - Density of air in kg m-3 + rho_dryair(i,k) = prsl(i,k) / (con_rd*save_tcp(i,k)) + !> - Convert specific humidity to dry mixing ratio + qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) + if (ntlnc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho_dryair(i,k), nwfa(i,k)) * (one/rho_dryair(i,k))) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) + endif + if (ntinc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) + !> - Convert number concentration from moist to dry + ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho_dryair(i,k), save_tcp(i,k)) * (one/rho_dryair(i,k))) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) + endif + enddo + enddo + endif + + else + do k=1,levs + do i=1,im + gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntiw + + else + do k=1,levs + do i=1,im + clw(i,k,1) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntcw + +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (cplchm) then + do k=1,levs + do i=1,im + dqdti(i,k) = dqdti(i,k) * (one / dtf) + enddo + enddo + endif + + end subroutine GFS_suite_interstitial_4_run + + end module GFS_suite_interstitial_4 + + module GFS_suite_interstitial_5 + + contains + + subroutine GFS_suite_interstitial_5_init () + end subroutine GFS_suite_interstitial_5_init + + subroutine GFS_suite_interstitial_5_finalize() + end subroutine GFS_suite_interstitial_5_finalize + +!> \section arg_table_GFS_suite_interstitial_5_run Argument Table +!! \htmlinclude GFS_suite_interstitial_5_run.html +!! + subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + + ! interface variables + integer, intent(in) :: im, levs, ntrac, ntcw, ntiw, nn + + real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 + + real(kind=kind_phys), dimension(im, levs, nn), intent(out) :: clw + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: i,k + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do k=1,levs + do i=1,im + clw(i,k,1) = gq0(i,k,ntiw) ! ice + clw(i,k,2) = gq0(i,k,ntcw) ! water + enddo + enddo + + end subroutine GFS_suite_interstitial_5_run + + end module GFS_suite_interstitial_5 + diff --git a/physics/debug/GFS_suite_interstitial.meta_dbg b/physics/debug/GFS_suite_interstitial.meta_dbg new file mode 100644 index 000000000..85d5fe1c8 --- /dev/null +++ b/physics/debug/GFS_suite_interstitial.meta_dbg @@ -0,0 +1,2014 @@ +[ccpp-table-properties] + name = GFS_suite_interstitial_rad_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_rad_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout + optional = F +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_phys_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_phys_reset_run + type = scheme +[Interstitial] + standard_name = GFS_interstitial_type_instance + long_name = derived type GFS_interstitial_type in FV3 + units = DDT + dimensions = () + type = GFS_interstitial_type + intent = inout + optional = F +[Model] + standard_name = GFS_control_type_instance + long_name = Fortran DDT containing FV3-GFS model control parameters + units = DDT + dimensions = () + type = GFS_control_type + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_1 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_1_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dxmin] + standard_name = minimum_scaling_factor_for_critical_relative_humidity + long_name = minimum scaling factor for critical relative humidity + units = m2 rad-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dxinv] + standard_name = inverse_scaling_factor_for_critical_relative_humidity + long_name = inverse scaling factor for critical relative humidity + units = rad2 m-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[psurf] + standard_name = surface_air_pressure_diag + long_name = surface air pressure diagnostic + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dqdt] + standard_name = tendency_of_tracers_due_to_model_physics + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_2 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_2_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lsidea] + standard_name = flag_idealized_physics + long_name = flag for idealized physics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[shal_cnv] + standard_name = flag_for_shallow_convection + long_name = flag for calling shallow convection + units = flag + dimensions = () + type = logical + intent = in + optional = F +[old_monin] + standard_name = flag_for_old_PBL_scheme + long_name = flag for using old PBL schemes + units = flag + dimensions = () + type = logical + intent = in + optional = F +[mstrat] + standard_name = flag_for_moorthi_stratus + long_name = flag for moorthi approach for stratus + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in + optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in + optional = F +[imfshalcnv] + standard_name = flag_for_mass_flux_shallow_convection_scheme + long_name = flag for mass-flux shallow convection scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xcosz] + standard_name = instantaneous_cosine_of_zenith_angle + long_name = cosine of zenith angle at current time + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ulwsfc_cice] + standard_name = surface_upwelling_longwave_flux_for_coupling + long_name = surface upwelling longwave flux for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lwhd] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_for_idea + long_name = idea sky lw heating rates + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension,6) + type = real + kind = kind_phys + intent = in + optional = F +[htrsw] + standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step + long_name = total sky sw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[htrlw] + standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step + long_name = total sky lw heating rate + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xmu] + standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes + long_name = zenith angle temporal adjustment factor for shortwave fluxes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ctei_rm] + standard_name = critical_cloud_top_entrainment_instability_criteria + long_name = critical cloud top entrainment instability criteria + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs_water_vapor] + standard_name = water_vapor_specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs_cloud_water] + standard_name = cloud_condensed_water_mixing_ratio + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[suntim] + standard_name = duration_of_sunshine + long_name = sunshine duration time + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[use_LW_jacobian] + standard_name = flag_to_calc_RRTMGP_LW_jacobian + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[adjsfculw_lnd] + standard_name = surface_upwelling_longwave_flux_over_land_interstitial + long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw_ice] + standard_name = surface_upwelling_longwave_flux_over_ice_interstitial + long_name = surface upwelling longwave flux at current time over ice (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw_wat] + standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial + long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dlwsfc] + standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface downwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ulwsfc] + standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep + long_name = cumulative surface upwelling LW flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[psmean] + standard_name = cumulative_surface_pressure_multiplied_by_timestep + long_name = cumulative surface pressure multiplied by timestep + units = Pa s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_lw] + standard_name = cumulative_change_in_temperature_due_to_longwave_radiation + long_name = cumulative change in temperature due to longwave radiation + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_sw] + standard_name = cumulative_change_in_temperature_due_to_shortwave_radiation + long_name = cumulative change in temperature due to shortwave radiation + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_pbl] + standard_name = cumulative_change_in_temperature_due_to_PBL + long_name = cumulative change in temperature due to PBL + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_dcnv] + standard_name = cumulative_change_in_temperature_due_to_deep_convection + long_name = cumulative change in temperature due to deep conv. + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_scnv] + standard_name = cumulative_change_in_temperature_due_to_shallow_convection + long_name = cumulative change in temperature due to shal conv. + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt_mp] + standard_name = cumulative_change_in_temperature_due_to_microphysics + long_name = cumulative change in temperature due to microphysics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ctei_rml] + standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria + long_name = grid sensitive critical cloud top entrainment instability criteria + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ctei_r] + standard_name = cloud_top_entrainment_instability_value + long_name = cloud top entrainment instability value + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[huge] + standard_name = netcdf_float_fillvalue + long_name = definition of NetCDF float FillValue + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = inout + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = inout + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_reset_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[gt0] + standard_name = air_temperature_updated_by_physics + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gu0] + standard_name = x_wind_updated_by_physics + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gv0] + standard_name = y_wind_updated_by_physics + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_update + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_stateout_update_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = updated tendency of the x wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = updated tendency of the y wind + units = m s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = updated tendency of the temperature + units = K s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dqdt] + standard_name = tendency_of_tracers_due_to_model_physics + long_name = updated tendency of the tracers + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[gt0] + standard_name = air_temperature_updated_by_physics + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gu0] + standard_name = x_wind_updated_by_physics + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gv0] + standard_name = y_wind_updated_by_physics + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = out + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[nqrimef] + standard_name = index_for_mass_weighted_rime_factor + long_name = tracer index for mass weighted rime factor + units = index + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_fer_hires] + standard_name = flag_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[epsq] + standard_name = minimum_value_of_specific_humidity + long_name = floor value for specific humidity + units = kg kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_3 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_3_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in + optional = F +[cscnv] + standard_name = flag_for_Chikira_Sugiyama_deep_convection + long_name = flag for Chikira-Sugiyama convection + units = flag + dimensions = () + type = logical + intent = in + optional = F +[satmedmf] + standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL + long_name = flag for scale-aware TKE moist EDMF PBL scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[trans_trac] + standard_name = flag_for_convective_transport_of_tracers + long_name = flag for convective transport of tracers + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_shoc] + standard_name = flag_for_shoc + long_name = flag for SHOC + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntclamt] + standard_name = index_for_cloud_amount + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgnc] + standard_name = index_for_graupel_number_concentration + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gt0] + standard_name = air_temperature_updated_by_physics + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_mg] + standard_name = flag_for_morrison_gettelman_microphysics_scheme + long_name = choice of Morrison-Gettelman microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_zhao_carr] + standard_name = flag_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_zhao_carr_pdf] + standard_name = flag_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_gfdl] + standard_name = flag_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_thompson] + standard_name = flag_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_wsm6] + standard_name = flag_for_wsm6_microphysics_scheme + long_name = choice of WSM6 microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_fer_hires] + standard_name = flag_for_fer_hires_microphysics_scheme + long_name = choice of Ferrier-Aligo microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rhcbot] + standard_name = critical_relative_humidity_at_surface + long_name = critical relative humidity at the surface + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhcpbl] + standard_name = critical_relative_humidity_at_PBL_top + long_name = critical relative humidity at the PBL top + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhctop] + standard_name = critical_relative_humidity_at_top_of_atmosphere + long_name = critical relative humidity at the top of atmosphere + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhcmax] + standard_name = maximum_critical_relative_humidity + long_name = maximum critical relative humidity + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[work1] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes + long_name = grid size related coefficient used in scale-sensitive schemes + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[work2] + standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement + long_name = complement to work1 + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = vertical index at top atmospheric boundary layer + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[ras] + standard_name = flag_for_ras_deep_convection + long_name = flag for ras convection scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout + optional = F +[rhc] + standard_name = critical_relative_humidity + long_name = critical relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_4 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_4_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ltaerosol] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol physics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[tracers_total] + standard_name = number_of_total_tracers + long_name = total number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntclamt] + standard_name = index_for_cloud_amount + long_name = tracer index for cloud amount integer + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrw] + standard_name = index_for_rain_water + long_name = tracer index for rain water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsw] + standard_name = index_for_snow_water + long_name = tracer index for snow water + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntrnc] + standard_name = index_for_rain_number_concentration + long_name = tracer index for rain number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntsnc] + standard_name = index_for_snow_number_concentration + long_name = tracer index for snow number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntgnc] + standard_name = index_for_graupel_number_concentration + long_name = tracer index for graupel number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntlnc] + standard_name = index_for_liquid_cloud_number_concentration + long_name = tracer index for liquid number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntinc] + standard_name = index_for_ice_cloud_number_concentration + long_name = tracer index for ice number concentration + units = index + dimensions = () + type = integer + intent = in + optional = F +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in + optional = F +[imp_physics] + standard_name = flag_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_gfdl] + standard_name = flag_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_thompson] + standard_name = flag_for_thompson_microphysics_scheme + long_name = choice of Thompson microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_zhao_carr] + standard_name = flag_for_zhao_carr_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[imp_physics_zhao_carr_pdf] + standard_name = flag_for_zhao_carr_pdf_microphysics_scheme + long_name = choice of Zhao-Carr microphysics scheme with PDF clouds + units = flag + dimensions = () + type = integer + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[save_qc] + standard_name = cloud_condensed_water_mixing_ratio_save + long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[save_qi] + standard_name = ice_water_mixing_ratio_save + long_name = cloud ice water mixing ratio before entering a physics scheme + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[save_tcp] + standard_name = air_temperature_save_from_convective_parameterization + long_name = air temperature after cumulus parameterization + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[nwfa] + standard_name = water_friendly_aerosol_number_concentration + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[spechum] + standard_name = water_vapor_specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dqdti] + standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection + long_name = instantaneous moisture tendency due to convection + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_5 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_suite_interstitial_5_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = tracer index for cloud condensate (or liquid water) + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntiw] + standard_name = index_for_ice_cloud_condensate + long_name = tracer index for ice water + units = index + dimensions = () + type = integer + intent = in + optional = F +[nn] + standard_name = number_of_tracers_for_convective_transport + long_name = number of tracers for convective transport + units = count + dimensions = () + type = integer + intent = in + optional = F +[gq0] + standard_name = tracer_concentration_updated_by_physics + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[clw] + standard_name = convective_transportable_tracers + long_name = array to contain cloud water and other convective trans. tracers + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/debug/GFS_surface_composites.F90_dbg b/physics/debug/GFS_surface_composites.F90_dbg new file mode 100644 index 000000000..e9eb86473 --- /dev/null +++ b/physics/debug/GFS_surface_composites.F90_dbg @@ -0,0 +1,689 @@ +!> \file GFS_surface_composites.F90 +!! Contains code related to generating composites for all GFS surface schemes. + +module GFS_surface_composites_pre + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + +contains + + subroutine GFS_surface_composites_pre_init () + end subroutine GFS_surface_composites_pre_init + + subroutine GFS_surface_composites_pre_finalize() + end subroutine GFS_surface_composites_pre_finalize + +!> \section arg_table_GFS_surface_composites_pre_run Argument Table +!! \htmlinclude GFS_surface_composites_pre_run.html +!! + subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, ocean, wet, hice, cice, zorl, zorlo, zorll, zorli, zorl_wat, & + zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & + weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & + gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & + qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + xlon, xlat, lprnt, ipr, kdt, & + min_lakeice, min_seaice, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im, lkm + integer, intent(inout) :: ipr, kdt + logical, intent(in ) :: frac_grid, cplflx, cplwav2atm + logical, intent(inout) :: lprnt + logical, dimension(im), intent(inout) :: flag_cice + logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet + real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac + real(kind=kind_phys), dimension(im), intent(inout) :: cice, hice + real(kind=kind_phys), dimension(im), intent( out) :: frland + real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd, qss, hflx + real(kind=kind_phys), dimension(im), intent(in ) :: xlon, xlat + + real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli, tsfc, tsfco, tsfcl, tisfc, tsurf + real(kind=kind_phys), dimension(im), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & + tprcp_lnd, tprcp_ice, zorl_wat, zorl_lnd, zorl_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat, & + tsurf_lnd, tsurf_ice, uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & + qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice + real(kind=kind_phys), dimension(im), intent( out) :: tice + real(kind=kind_phys), intent(in ) :: tgice + integer, dimension(im), intent(inout) :: islmsk, islmsk_cice + real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad + real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk + real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice + + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + + real(kind=kind_phys), parameter :: degrad = 180.0/3.1415926 + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + lprnt = .false. + do i=1,im +! lprnt = kdt > 16052 .and. abs(xlon(i)*degrad-106.9) < 0.1 & +! lprnt = kdt > 16020 .and. abs(xlon(i)*degrad-106.9) < 0.1 & +! .and. abs(xlat(i)*degrad+32.00) < 0.1 + lprnt = kdt > 285 .and. kdt < 291 .and. abs(xlon(i)*degrad-70.5) < 0.1 & + .and. abs(xlat(i)*degrad-39.23) < 0.1 + if (lprnt) then + ipr = i + write(0,*)' lprnt=',lprnt,' ipr=',ipr,' xlon_d=',xlon(i)*degrad,' xlat_d=',xlat(i)*degrad + exit + endif + enddo + + if (frac_grid) then ! cice is ice fraction wrt water area + do i=1,im + frland(i) = landfrac(i) + if (frland(i) > zero) dry(i) = .true. + if (frland(i) < one) then + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + islmsk(i) = 2 + tisfc(i) = max(timin, min(tisfc(i), tgice)) + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + else ! all land + cice(i) = zero + hice(i) = zero + islmsk_cice(i) = 1 + islmsk(i) = 1 + endif + enddo + + else + + do i = 1, IM + if (islmsk(i) == 1) then +! tsfcl(i) = tsfc(i) + dry(i) = .true. + frland(i) = one + cice(i) = zero + hice(i) = zero + else + frland(i) = zero + if (oceanfrac(i) > zero) then + if (cice(i) >= min_seaice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + flag_cice(i) = .false. + islmsk(i) = 0 + islmsk_cice(i) = 0 + endif + if (cice(i) < one) then + wet(i) = .true. ! some open ocean + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + else + if (cice(i) >= min_lakeice) then + icy(i) = .true. + tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 + else + cice(i) = zero + hice(i) = zero + islmsk(i) = 0 + endif + islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. + if (cice(i) < one) then + wet(i) = .true. ! some open lake + if (icy(i)) tsfco(i) = max(tisfc(i), tgice) + endif + endif + endif + enddo + endif + + if (lprnt) write(0,*)' tisfc1=',tisfc(ipr),' kdt=',kdt + +! if (.not. cplflx .or. .not. frac_grid) then +! if (cplwav2atm) then +! do i=1,im +! zorll(i) = zorl(i) +! enddo +! else +! do i=1,im +! zorll(i) = zorl(i) +! zorlo(i) = zorl(i) +! enddo +! endif +! endif + + do i=1,im + tprcp_wat(i) = tprcp(i) + tprcp_lnd(i) = tprcp(i) + tprcp_ice(i) = tprcp(i) + if (wet(i)) then ! Water +! uustar_wat(i) = uustar(i) + zorl_wat(i) = zorlo(i) + tsfc_wat(i) = tsfco(i) + tsurf_wat(i) = tsfco(i) +! weasd_wat(i) = weasd(i) +! snowd_wat(i) = snowd(i) + weasd_wat(i) = zero + snowd_wat(i) = zero + semis_wat(i) = 0.97_kind_phys +! semis_wat(i) = 0.984_kind_phys +! qss_wat(i) = qss(i) +! hflx_wat(i) = hflx(i) + endif + if (dry(i)) then ! Land + uustar_lnd(i) = uustar(i) + weasd_lnd(i) = weasd(i) + zorl_lnd(i) = zorll(i) + tsfc_lnd(i) = tsfcl(i) + tsurf_lnd(i) = tsfcl(i) +! snowd_lnd(i) = snowd(i) / frland(i) + semis_lnd(i) = semis_rad(i) +! qss_lnd(i) = qss(i) +! hflx_lnd(i) = hflx(i) + end if + if (icy(i)) then ! Ice + uustar_ice(i) = uustar(i) + weasd_ice(i) = weasd(i) + zorl_ice(i) = zorli(i) + tsfc_ice(i) = tisfc(i) + tsurf_ice(i) = tisfc(i) +! snowd_ice(i) = snowd(i) / cice(i) + ep1d_ice(i) = zero + gflx_ice(i) = zero + semis_ice(i) = 0.96_kind_phys +! semis_ice(i) = 0.95_kind_phys +! qss_ice(i) = qss(i) +! hflx_ice(i) = hflx(i) + endif + if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) + enddo + +! to prepare to separate lake from ocean under water category + do i = 1, im + if(lkm == 1) then + if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then + lake(i) = .true. + else + lake(i) = .false. + endif + else + lake(i) = .false. + endif + enddo +! + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + snowd_lnd(i) = snowd(i) / (frland(i) + cice(i)) + snowd_ice(i) = snowd_lnd(i) + else + snowd_lnd(i) = snowd(i) / frland(i) + snowd_ice(i) = zero + endif + elseif (icy(i)) then + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) / cice(i) + endif + enddo + else + do i=1,im + if (dry(i)) then + snowd_lnd(i) = snowd(i) + snowd_ice(i) = zero + elseif (icy(i)) then + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) / cice(i) + endif + enddo + endif + + ! Assign sea ice temperature to interstitial variable + do i = 1, im + tice(i) = tisfc(i) + enddo + + if (lprnt) write(0,*)' tisfc2=',tisfc(ipr),' tice=',tice(ipr),' kdt=',kdt + + end subroutine GFS_surface_composites_pre_run + +end module GFS_surface_composites_pre + + +module GFS_surface_composites_inter + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_inter_init, GFS_surface_composites_inter_finalize, GFS_surface_composites_inter_run + +contains + + subroutine GFS_surface_composites_inter_init () + end subroutine GFS_surface_composites_inter_init + + subroutine GFS_surface_composites_inter_finalize() + end subroutine GFS_surface_composites_inter_finalize + +!> \section arg_table_GFS_surface_composites_inter_run Argument Table +!! \htmlinclude GFS_surface_composites_inter_run.html +!! + subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat, & + adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: im + logical, dimension(im), intent(in ) :: dry, icy, wet + real(kind=kind_phys), dimension(im), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & + adjsfcdsw, adjsfcnsw + real(kind=kind_phys), dimension(im), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat + real(kind=kind_phys), dimension(im), intent(out) :: adjsfcusw + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw + ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. + ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. + ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. + ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean + ! models as downward flux) is not the same as adjsfcdlw but a value reduced by + ! the factor of emissivity. however, the net effects are the same when seeing + ! it either above the surface interface or below. + ! + ! - flux above the interface used by atmosphere model: + ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! - flux below the interface used by lnd/oc/ice models: + ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 + ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + ! surface upwelling shortwave flux at current time is in adjsfcusw + + ! --- ... define the downward lw flux absorbed by ground + do i=1,im + if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) + if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) + if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) + adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) + enddo + + end subroutine GFS_surface_composites_inter_run + +end module GFS_surface_composites_inter + + +module GFS_surface_composites_post + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + +contains + + subroutine GFS_surface_composites_post_init () + end subroutine GFS_surface_composites_post_init + + subroutine GFS_surface_composites_post_finalize() + end subroutine GFS_surface_composites_post_finalize + +#if 0 +!> \section arg_table_GFS_surface_composites_post_run Argument Table +!! \htmlinclude GFS_surface_composites_post_run.html +!! +#endif + subroutine GFS_surface_composites_post_run ( & + im, kice, km, cplflx, cplwav2atm, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & + zorl, zorlo, zorll, zorli, zorl_wat, zorl_lnd, zorl_ice, & + cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & + stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & + uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & + cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & + ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, lprnt, ipr, kdt, errmsg, errflg) + + implicit none + + integer, intent(in) :: im, kice, km + logical, intent(in) :: cplflx, frac_grid, cplwav2atm + logical, dimension(im), intent(in) :: flag_cice, dry, wet, icy + integer, dimension(im), intent(in) :: islmsk + real(kind=kind_phys), dimension(im), intent(in) :: landfrac, lakefrac, oceanfrac, & + zorl_wat, zorl_lnd, zorl_ice, cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & + stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & + fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & + chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & + snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & + hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice + + real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, zorli, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & + fh2, tsurf, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc + + real(kind=kind_phys), dimension(im), intent(in ) :: tice ! interstitial sea ice temperature + real(kind=kind_phys), dimension(im), intent(inout) :: hice, cice + real(kind=kind_phys), intent(in ) :: min_seaice + + real(kind=kind_phys), dimension(im, kice), intent(in ) :: tiice + real(kind=kind_phys), dimension(im, km), intent(inout) :: stc + logical, intent(in) :: lprnt + integer, intent(in) :: ipr, kdt + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + real(kind=kind_phys) :: txl, txi, txo, wfrac + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! --- generate ocean/land/ice composites + + if (frac_grid) then + + do i=1, im + + ! Three-way composites (fields from sfc_diff) + txl = landfrac(i) ! land fraction + wfrac = one - txl ! ocean fraction + txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell + txo = max(zero, wfrac-txi) ! txo = open water fraction + + zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) + cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) + cdq(i) = txl*cdq_lnd(i) + txi*cdq_ice(i) + txo*cdq_wat(i) + rb(i) = txl*rb_lnd(i) + txi*rb_ice(i) + txo*rb_wat(i) + stress(i) = txl*stress_lnd(i) + txi*stress_ice(i) + txo*stress_wat(i) + ffmm(i) = txl*ffmm_lnd(i) + txi*ffmm_ice(i) + txo*ffmm_wat(i) + ffhh(i) = txl*ffhh_lnd(i) + txi*ffhh_ice(i) + txo*ffhh_wat(i) + uustar(i) = txl*uustar_lnd(i) + txi*uustar_ice(i) + txo*uustar_wat(i) + fm10(i) = txl*fm10_lnd(i) + txi*fm10_ice(i) + txo*fm10_wat(i) + fh2(i) = txl*fh2_lnd(i) + txi*fh2_ice(i) + txo*fh2_wat(i) + !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) + !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_wat(i) ! not used again! Moorthi + cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_wat(i) + chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_wat(i) + !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) + ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) + !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_wat(i) + !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_wat(i) + weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) + + if (.not. flag_cice(i) .and. islmsk(i) == 2) then + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + else + evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) + hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) + qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_wat(i) + gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) + endif + tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_wat(i) + + zorll(i) = zorl_lnd(i) + zorli(i) = zorl_ice(i) + zorlo(i) = zorl_wat(i) + + if (dry(i)) then + tsfcl(i) = tsfc_lnd(i) ! over land + elseif (wet(i)) then + tsfcl(i) = tsfc_wat(i) ! over water + else + tsfcl(i) = tice(i) ! over ice + endif + if (wet(i)) then + tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + elseif (icy(i)) then + tsfco(i) = tice(i) ! over lake or ocean ice when uncoupled + else + tsfco(i) = tsfc_lnd(i) ! over land + endif + if (icy(i)) then + tisfc(i) = tice(i) ! over lake or ocean ice when uncoupled + elseif (wet(i)) then + tisfc(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + else + tisfc(i) = tsfc_lnd(i) ! over land + endif + ! for coupled model ocean will replace this +! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled +! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled + +! if (wet(i) .and. .not. cplflx) then +! tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled +! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled +! endif + +! if (.not. flag_cice(i)) then +! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array +! tisfc(i) = tice(i) +! else ! this would be over open ocean or land (no ice fraction) +! hice(i) = zero +! cice(i) = zero +! tisfc(i) = tsfc(i) +! endif +! endif + if (.not. icy(i)) then + hice(i) = zero + cice(i) = zero + endif + enddo + + else + + do i=1,im + if (islmsk(i) == 1) then + zorl(i) = zorl_lnd(i) + cd(i) = cd_lnd(i) + cdq(i) = cdq_lnd(i) + rb(i) = rb_lnd(i) + stress(i) = stress_lnd(i) + ffmm(i) = ffmm_lnd(i) + ffhh(i) = ffhh_lnd(i) + uustar(i) = uustar_lnd(i) + fm10(i) = fm10_lnd(i) + fh2(i) = fh2_lnd(i) + !tsurf(i) = tsurf_lnd(i) + tsfcl(i) = tsfc_lnd(i) ! over land + tsfc(i) = tsfcl(i) + tsfco(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) + gflx(i) = gflx_lnd(i) + ep1d(i) = ep1d_lnd(i) + weasd(i) = weasd_lnd(i) + snowd(i) = snowd_lnd(i) + evap(i) = evap_lnd(i) + hflx(i) = hflx_lnd(i) + qss(i) = qss_lnd(i) + hice(i) = zero + cice(i) = zero + elseif (islmsk(i) == 0) then + zorl(i) = zorl_wat(i) + cd(i) = cd_wat(i) + cdq(i) = cdq_wat(i) + rb(i) = rb_wat(i) + stress(i) = stress_wat(i) + ffmm(i) = ffmm_wat(i) + ffhh(i) = ffhh_wat(i) + uustar(i) = uustar_wat(i) + fm10(i) = fm10_wat(i) + fh2(i) = fh2_wat(i) + !tsurf(i) = tsurf_wat(i) + tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) + tsfc(i) = tsfco(i) + tsfcl(i) = tsfc(i) + tisfc(i) = tsfc(i) + cmm(i) = cmm_wat(i) + chh(i) = chh_wat(i) + gflx(i) = gflx_wat(i) + ep1d(i) = ep1d_wat(i) + weasd(i) = weasd_wat(i) + snowd(i) = snowd_wat(i) + evap(i) = evap_wat(i) + hflx(i) = hflx_wat(i) + qss(i) = qss_wat(i) + hice(i) = zero + cice(i) = zero + else ! islmsk(i) == 2 + zorl(i) = zorl_ice(i) + cd(i) = cd_ice(i) + cdq(i) = cdq_ice(i) + rb(i) = rb_ice(i) + ffmm(i) = ffmm_ice(i) + ffhh(i) = ffhh_ice(i) + uustar(i) = uustar_ice(i) + fm10(i) = fm10_ice(i) + fh2(i) = fh2_ice(i) + stress(i) = stress_ice(i) + !tsurf(i) = tsurf_ice(i) + cmm(i) = cmm_ice(i) + chh(i) = chh_ice(i) + gflx(i) = gflx_ice(i) + ep1d(i) = ep1d_ice(i) + weasd(i) = weasd_ice(i) + snowd(i) = snowd_ice(i) + qss(i) = qss_ice(i) + tsfc(i) = tsfc_ice(i) + evap(i) = evap_ice(i) + hflx(i) = hflx_ice(i) + qss(i) = qss_ice(i) + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) +! + if (flag_cice(i)) then + if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_wat(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + qss(i) = txi * qss_ice(i) + txo * qss_wat(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) + zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) + snowd(i) = txi * snowd_ice(i) + endif + elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array + zorl(i) = cice(i)*zorl_ice(i) + (one-cice(i))*zorl_wat(i) + endif +! + if (wet(i)) then + tsfco(i) = tsfc_wat(i) + else + tsfco(i) = tsfc(i) + endif + tsfcl(i) = tsfc(i) + do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case + stc(i,k) = tiice(i,k) + enddo + endif + + zorll(i) = zorl_lnd(i) + zorlo(i) = zorl_wat(i) + zorli(i) = zorl_ice(i) + + enddo + + if (lprnt) write(0,*)' tisfc=',tisfc(ipr),' tice=',tice(ipr),' kdt=',kdt + if (lprnt) write(0,*)' tsfc=',tsfc(ipr),' tice=',tice(ipr),' kdt=',kdt + if (lprnt) write(0,*)' hflx=',hflx(ipr),' evap=',evap(ipr),' cice=',cice(ipr),' kdt=',kdt,& + ' hflx_wat=',hflx_wat(ipr),' wet=',wet(ipr),' evap_wat=',evap_wat(ipr) + + endif ! if (frac_grid) + + ! --- compositing done + + end subroutine GFS_surface_composites_post_run + +end module GFS_surface_composites_post diff --git a/physics/debug/GFS_surface_composites.meta_dbg b/physics/debug/GFS_surface_composites.meta_dbg new file mode 100644 index 000000000..595841fd7 --- /dev/null +++ b/physics/debug/GFS_surface_composites.meta_dbg @@ -0,0 +1,1928 @@ +[ccpp-table-properties] + name = GFS_surface_composites_pre + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[lkm] + standard_name = flag_for_lake_surface_scheme + long_name = flag for lake surface model + units = flag + dimensions = () + type = integer + intent = in + optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplwav2atm] + standard_name = flag_for_wave_coupling_to_atm + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lakedepth] + standard_name = lake_depth + long_name = lake depth + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[frland] + standard_name = land_area_fraction_for_microphysics + long_name = land area fraction used in microphysics schemes + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[lake] + standard_name = flag_nonzero_lake_surface_fraction + long_name = flag indicating presence of some lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[ocean] + standard_name = flag_nonzero_ocean_surface_fraction + long_name = flag indicating presence of some ocean surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zorlo] + standard_name = surface_roughness_length_over_ocean + long_name = surface roughness length over ocean + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl_wat] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl_lnd] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl_ice] + standard_name = surface_roughness_length_over_ice_interstitial + long_name = surface roughness length over ice (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowd] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowd_wat] + standard_name = surface_snow_thickness_water_equivalent_over_ocean + long_name = water equivalent snow depth over ocean + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowd_lnd] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowd_ice] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total precipitation amount in each time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tprcp_wat] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean + long_name = total precipitation amount in each time step over ocean + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp_lnd] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp_ice] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice + long_name = total precipitation amount in each time step over ice + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[uustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[uustar_wat] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[uustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[uustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd_wat] + standard_name = water_equivalent_accumulated_snow_depth_over_ocean + long_name = water equiv of acc snow depth over ocean + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd_lnd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd_ice] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ep1d_ice] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_wat] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_lnd] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_ice] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tisfc] + standard_name = sea_ice_temperature + long_name = sea ice surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tice] + standard_name = sea_ice_temperature_interstitial + long_name = sea ice surface skin temperature use as interstitial + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration + long_name = surface skin temperature after iteration + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_ocean + long_name = surface skin temperature after iteration over ocean + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflx_ice] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[semis_rad] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[semis_wat] + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qss] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qss_wat] + standard_name = surface_specific_humidity_over_ocean + long_name = surface air saturation specific humidity over ocean + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qss_lnd] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflx_wat] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ocean + long_name = kinematic surface upward sensible heat flux over ocean + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx_lnd] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx_ice] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice + long_name = kinematic surface upward sensible heat flux over ice + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[xlon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = inout + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = inout + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_inter + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_inter_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[semis_wat] + standard_name = surface_longwave_emissivity_over_ocean_interstitial + long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[semis_lnd] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[semis_ice] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gabsbdlw_lnd] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gabsbdlw_ice] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gabsbdlw_wat] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ocean + long_name = total sky surface downward longwave flux absorbed by the ground over ocean + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[adjsfcusw] + standard_name = surface_upwelling_shortwave_flux + long_name = surface upwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcnsw] + standard_name = surface_net_downwelling_shortwave_flux + long_name = surface net downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_post + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_composites_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[kice] + standard_name = ice_vertical_dimension + long_name = vertical loop extent for ice levels, start at 1 + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplwav2atm] + standard_name = flag_for_wave_coupling_to_atm + long_name = flag controlling ocean wave coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorlo] + standard_name = surface_roughness_length_over_ocean + long_name = surface roughness length over ocean + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl_wat] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zorl_lnd] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zorl_ice] + standard_name = surface_roughness_length_over_ice_interstitial + long_name = surface roughness length over ice (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cd] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cd_wat] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean + long_name = surface exchange coeff for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cd_lnd] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cd_ice] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice + long_name = surface exchange coeff for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cdq] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cdq_wat] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean + long_name = surface exchange coeff heat & moisture over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cdq_lnd] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cdq_ice] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice + long_name = surface exchange coeff heat & moisture over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rb] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_wat] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean + long_name = bulk Richardson number at the surface over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rb_lnd] + standard_name = bulk_richardson_number_at_lowest_model_level_over_land + long_name = bulk Richardson number at the surface over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[rb_ice] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ice + long_name = bulk Richardson number at the surface over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_wat] + standard_name = surface_wind_stress_over_ocean + long_name = surface wind stress over ocean + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[stress_lnd] + standard_name = surface_wind_stress_over_land + long_name = surface wind stress over land + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[stress_ice] + standard_name = surface_wind_stress_over_ice + long_name = surface wind stress over ice + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffmm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin-Obukhov similarity function for momentum + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ffmm_wat] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean + long_name = Monin-Obukhov similarity function for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffmm_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land + long_name = Monin-Obukhov similarity function for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffmm_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice + long_name = Monin-Obukhov similarity function for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffhh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin-Obukhov similarity function for heat + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ffhh_wat] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean + long_name = Monin-Obukhov similarity function for heat over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffhh_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_land + long_name = Monin-Obukhov similarity function for heat over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ffhh_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice + long_name = Monin-Obukhov similarity function for heat over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[uustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[uustar_wat] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[uustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[uustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m + long_name = Monin-Obukhov similarity parameter for momentum at 10m + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_wat] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land + long_name = Monin-Obukhov similarity parameter for momentum at 10m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fh2] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m + long_name = Monin-Obukhov similarity parameter for heat at 2m + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_wat] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean + long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fh2_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land + long_name = Monin-Obukhov similarity parameter for heat at 2m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fh2_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice + long_name = Monin-Obukhov similarity parameter for heat at 2m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration + long_name = surface skin temperature after iteration + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_ocean + long_name = surface skin temperature after iteration over ocean + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air + long_name = momentum exchange coefficient + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmm_wat] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ocean + long_name = momentum exchange coefficient over ocean + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cmm_lnd] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cmm_ice] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice + long_name = momentum exchange coefficient over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air + long_name = thermal exchange coefficient + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chh_wat] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ocean + long_name = thermal exchange coefficient over ocean + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[chh_lnd] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[chh_ice] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice + long_name = thermal exchange coefficient over ice + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gflx] + standard_name = upward_heat_flux_in_soil + long_name = soil heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflx_wat] + standard_name = upward_heat_flux_in_soil_over_ocean + long_name = soil heat flux over ocean + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gflx_lnd] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gflx_ice] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ep1d] + standard_name = surface_upward_potential_latent_heat_flux + long_name = surface upward potential latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ep1d_wat] + standard_name = surface_upward_potential_latent_heat_flux_over_ocean + long_name = surface upward potential latent heat flux over ocean + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ep1d_lnd] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ep1d_ice] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth + long_name = water equiv of acc snow depth over land and sea ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd_wat] + standard_name = water_equivalent_accumulated_snow_depth_over_ocean + long_name = water equiv of acc snow depth over ocean + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd_lnd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[weasd_ice] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowd] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowd_wat] + standard_name = surface_snow_thickness_water_equivalent_over_ocean + long_name = water equivalent snow depth over ocean + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowd_lnd] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowd_ice] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total precipitation amount in each time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp_wat] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean + long_name = total precipitation amount in each time step over ocean + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tprcp_lnd] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tprcp_ice] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice + long_name = total precipitation amount in each time step over ice + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evap_wat] + standard_name = kinematic_surface_upward_latent_heat_flux_over_ocean + long_name = kinematic surface upward latent heat flux over ocean + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evap_lnd] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evap_ice] + standard_name = kinematic_surface_upward_latent_heat_flux_over_ice + long_name = kinematic surface upward latent heat flux over ice + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx_wat] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ocean + long_name = kinematic surface upward sensible heat flux over ocean + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflx_lnd] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflx_ice] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice + long_name = kinematic surface upward sensible heat flux over ice + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qss] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qss_wat] + standard_name = surface_specific_humidity_over_ocean + long_name = surface air saturation specific humidity over ocean + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qss_lnd] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qss_ice] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfco] + standard_name = sea_surface_temperature + long_name = sea surface temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfcl] + standard_name = surface_skin_temperature_over_land + long_name = surface skin temperature over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfc_wat] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_lnd] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_ice] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tisfc] + standard_name = sea_ice_temperature + long_name = sea ice surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tice] + standard_name = sea_ice_temperature_interstitial + long_name = sea ice surface skin temperature use as interstitial + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hice] + standard_name = sea_ice_thickness + long_name = sea ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in +[tiice] + standard_name = internal_ice_temperature + long_name = sea ice internal temperature + units = K + dimensions = (horizontal_loop_extent,ice_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/debug/GFS_surface_generic.F90_dbg b/physics/debug/GFS_surface_generic.F90_dbg new file mode 100644 index 000000000..a26633a5a --- /dev/null +++ b/physics/debug/GFS_surface_generic.F90_dbg @@ -0,0 +1,400 @@ +!> \file GFS_surface_generic.F90 +!! Contains code related to all GFS surface schemes. + + module GFS_surface_generic_pre + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + + contains + + subroutine GFS_surface_generic_pre_init () + end subroutine GFS_surface_generic_pre_init + + subroutine GFS_surface_generic_pre_finalize() + end subroutine GFS_surface_generic_pre_finalize + +!> \section arg_table_GFS_surface_generic_pre_run Argument Table +!! \htmlinclude GFS_surface_generic_pre_run.html +!! + subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + prsik_1, prslk_1, tsfc, phil, con_g, & + lprnt, ipr, kdt, & + sigmaf, soiltyp, vegtype, slopetyp, work3, tsurf, zlvl, & + drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & + lndp_var_list, lndp_prt_list, & + z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, sfc_wts_inv, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & + wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) + + use surface_perturbation, only: cdfnor + + implicit none + + ! Interface variables + logical, intent(in) :: lprnt + integer, intent(in) :: im, levs, isot, ivegsrc, ipr, kdt + integer, dimension(im), intent(in) :: islmsk + integer, dimension(im), intent(inout) :: soiltyp, vegtype, slopetyp + + real(kind=kind_phys), intent(in) :: con_g + real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1 + + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc + real(kind=kind_phys), dimension(im,levs), intent(in) :: phil + + real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, tsurf, zlvl + + ! Stochastic physics / surface perturbations + real(kind=kind_phys), dimension(im), intent(out) :: drain_cpl + real(kind=kind_phys), dimension(im), intent(out) :: dsnow_cpl + real(kind=kind_phys), dimension(im), intent(in) :: rain_cpl + real(kind=kind_phys), dimension(im), intent(in) :: snow_cpl + integer, intent(in) :: lndp_type + integer, intent(in) :: n_var_lndp + character(len=3), dimension(n_var_lndp), intent(in) :: lndp_var_list + real(kind=kind_phys), dimension(n_var_lndp), intent(in) :: lndp_prt_list + real(kind=kind_phys), dimension(im,n_var_lndp), intent(in) :: sfc_wts + real(kind=kind_phys), dimension(im), intent(out) :: z01d + real(kind=kind_phys), dimension(im), intent(out) :: zt1d + real(kind=kind_phys), dimension(im), intent(out) :: bexp1d + real(kind=kind_phys), dimension(im), intent(out) :: xlai1d + real(kind=kind_phys), dimension(im), intent(out) :: vegf1d + real(kind=kind_phys), intent(out) :: lndp_vgf + real(kind=kind_phys), dimension(im,n_var_lndp), intent(inout) :: sfc_wts_inv + + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl + logical, dimension(im), intent(inout) :: flag_cice + integer, dimension(im), intent(out) :: islmsk_cice + + real(kind=kind_phys), dimension(im), intent(out) :: wind + real(kind=kind_phys), dimension(im), intent(in ) :: u1, v1 + ! surface wind enhancement due to convection + real(kind=kind_phys), dimension(im), intent(inout ) :: cnvwind + ! + real(kind=kind_phys), dimension(im), intent(out) :: smcwlt2, smcref2 + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i, k + real(kind=kind_phys) :: onebg + real(kind=kind_phys) :: cdfz + + ! Set constants + onebg = 1.0/con_g + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + + ! Scale random patterns for surface perturbations with perturbation size + ! Turn vegetation fraction pattern into percentile pattern + lndp_vgf=-999. + + if (lprnt) write(0,*)' lndp_type=',lndp_type + if (lndp_type>0) then + sfc_wts_inv(:,:)=sfc_wts(:,:) + endif + if (lndp_type==1) then + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') + z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') + xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('vgf') + ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff + do i=1,im + call cdfnor(sfc_wts(i,k),cdfz) + vegf1d(i) = cdfz + enddo + lndp_vgf = lndp_prt_list(k) + end select + enddo + endif + + ! End of stochastic physics / surface perturbation + + do i=1,im + sigmaf(i) = max(vfrac(i), 0.01_kind_phys) + islmsk_cice(i) = islmsk(i) + if (islmsk(i) == 2) then + if (isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (ivegsrc == 0 .or. ivegsrc == 4) then + vegtype(i) = 24 + elseif (ivegsrc == 1) then + vegtype(i) = 15 + elseif (ivegsrc == 2) then + vegtype(i) = 13 + elseif (ivegsrc == 3 .or. ivegsrc == 5) then + vegtype(i) = 15 + endif + slopetyp(i) = 9 + else + soiltyp(i) = int( stype(i)+0.5_kind_phys ) + vegtype(i) = int( vtype(i)+0.5_kind_phys ) + slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp + if (soiltyp(i) < 1) soiltyp(i) = 14 + if (vegtype(i) < 1) vegtype(i) = 17 + if (slopetyp(i) < 1) slopetyp(i) = 1 + endif + + work3(i) = prsik_1(i) / prslk_1(i) + + if (lprnt .and. i == ipr) then + write(0,*)' phil=',phil(i,1),' u1=',u1(i),' v1=',v1(i),& + ' cnvwind=',cnvwind(i),' onebg=',onebg,' work3=',work3(i) + endif + + !tsurf(i) = tsfc(i) + zlvl(i) = phil(i,1) * onebg + smcwlt2(i) = zero + smcref2(i) = zero + + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + cnvwind(i) = zero + + enddo + + if (cplflx) then + do i=1,im + islmsk_cice(i) = nint(slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + enddo + endif + + end subroutine GFS_surface_generic_pre_run + + end module GFS_surface_generic_pre + + + module GFS_surface_generic_post + + use machine, only: kind_phys + + implicit none + + private + + public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run + + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + + contains + + subroutine GFS_surface_generic_post_init () + end subroutine GFS_surface_generic_post_init + + subroutine GFS_surface_generic_post_finalize() + end subroutine GFS_surface_generic_post_finalize + +!> \section arg_table_GFS_surface_generic_post_run Argument Table +!! \htmlinclude GFS_surface_generic_post_run.html +!! + subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& + adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & + adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & + epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & + dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & + v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & + nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & + runoff, srunoff, runof, drain, lheatstrg, z0fac, e0fac, zorl, hflx, evap, hflxq, evapq, hffac, hefac, errmsg, errflg) + + implicit none + + integer, intent(in) :: im + logical, intent(in) :: cplflx, cplwav, lssav + logical, dimension(im), intent(in) :: icy, wet + real(kind=kind_phys), intent(in) :: dtf + + real(kind=kind_phys), dimension(im), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf + + real(kind=kind_phys), dimension(im), intent(inout) :: epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, & + dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, & + nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, & + nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, & + evcwa, transa, sbsnoa, snowca, snohfa, ep + + real(kind=kind_phys), dimension(im), intent(inout) :: runoff, srunoff + real(kind=kind_phys), dimension(im), intent(in) :: drain, runof + + ! For canopy heat storage + logical, intent(in) :: lheatstrg + real(kind=kind_phys), intent(in) :: z0fac, e0fac + real(kind=kind_phys), dimension(im), intent(in) :: zorl + real(kind=kind_phys), dimension(im), intent(in) :: hflx, evap + real(kind=kind_phys), dimension(im), intent(out) :: hflxq, evapq + real(kind=kind_phys), dimension(im), intent(out) :: hffac, hefac + + ! CCPP error handling variables + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys + + ! Parameters for canopy heat storage parametrization + real(kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 + real(kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 + + integer :: i + real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl + real(kind=kind_phys) :: tem, tem1, tem2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + epi(i) = ep1d(i) + gfluxi(i) = gflx(i) + t1(i) = tgrs_1(i) + q1(i) = qgrs_1(i) + u1(i) = ugrs_1(i) + v1(i) = vgrs_1(i) + enddo + + if (cplflx .or. cplwav) then + do i=1,im + u10mi_cpl(i) = u10m(i) + v10mi_cpl(i) = v10m(i) + enddo + endif + + if (cplflx) then + do i=1,im + dlwsfci_cpl (i) = adjsfcdlw(i) + dswsfci_cpl (i) = adjsfcdsw(i) + dlwsfc_cpl (i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf + dswsfc_cpl (i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf + dnirbmi_cpl (i) = adjnirbmd(i) + dnirdfi_cpl (i) = adjnirdfd(i) + dvisbmi_cpl (i) = adjvisbmd(i) + dvisdfi_cpl (i) = adjvisdfd(i) + dnirbm_cpl (i) = dnirbm_cpl(i) + adjnirbmd(i)*dtf + dnirdf_cpl (i) = dnirdf_cpl(i) + adjnirdfd(i)*dtf + dvisbm_cpl (i) = dvisbm_cpl(i) + adjvisbmd(i)*dtf + dvisdf_cpl (i) = dvisdf_cpl(i) + adjvisdfd(i)*dtf + nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) + if (wet(i)) then + nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw_wat(i) + endif + nlwsfc_cpl (i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf + t2mi_cpl (i) = t2m(i) + q2mi_cpl (i) = q2m(i) + tsfci_cpl (i) = tsfc(i) +! tsfci_cpl (i) = tsfc_wat(i) + psurfi_cpl (i) = pgr(i) + enddo + +! --- estimate mean albedo for ocean point without ice cover and apply +! them to net SW heat fluxes + + do i=1,im +! if (Sfcprop%landfrac(i) < one) then ! Not 100% land + if (wet(i)) then ! some open water +! --- compute open water albedo + xcosz_loc = max( zero, min( one, xcosz(i) )) + ocalnirdf_cpl = 0.06_kind_phys + ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & + & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & + & * (xcosz_loc-one)) + ocalvisdf_cpl = 0.06_kind_phys + ocalvisbm_cpl = ocalnirbm_cpl + + nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) + nnirdfi_cpl(i) = adjnirdfd(i) * (one-ocalnirdf_cpl) + nvisbmi_cpl(i) = adjvisbmd(i) * (one-ocalvisbm_cpl) + nvisdfi_cpl(i) = adjvisdfd(i) * (one-ocalvisdf_cpl) + else + nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) + nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) + nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) + endif + nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) & + + nvisbmi_cpl(i) + nvisdfi_cpl(i) + nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf + nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf + nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf + nvisbm_cpl(i) = nvisbm_cpl(i) + nvisbmi_cpl(i)*dtf + nvisdf_cpl(i) = nvisdf_cpl(i) + nvisdfi_cpl(i)*dtf + enddo + endif + + if (lssav) then + do i=1,im + gflux(i) = gflux(i) + gflx(i) * dtf + evbsa(i) = evbsa(i) + evbs(i) * dtf + evcwa(i) = evcwa(i) + evcw(i) * dtf + transa(i) = transa(i) + trans(i) * dtf + sbsnoa(i) = sbsnoa(i) + sbsno(i) * dtf + snowca(i) = snowca(i) + snowc(i) * dtf + snohfa(i) = snohfa(i) + snohf(i) * dtf + ep(i) = ep(i) + ep1d(i) * dtf + +! --- ... total runoff is composed of drainage into water table and +! runoff at the surface and is accumulated in unit of meters + runoff(i) = runoff(i) + (drain(i)+runof(i)) * dtf + srunoff(i) = srunoff(i) + runof(i) * dtf + enddo + endif + +! --- ... Boundary Layer and Free atmospheic turbulence parameterization +! +! in order to achieve heat storage within canopy layer, in the canopy heat +! storage parameterization the kinematic sensible and latent heat fluxes +! (hflx & evap) as surface boundary forcings to the pbl scheme are +! reduced as a function of surface roughness +! + do i=1,im + hflxq(i) = hflx(i) + evapq(i) = evap(i) + hffac(i) = one + hefac(i) = one + enddo + if (lheatstrg) then + do i=1,im + tem = 0.01_kind_phys * zorl(i) ! change unit from cm to m + tem1 = (tem - z0min) / (z0max - z0min) + hffac(i) = z0fac * min(max(tem1, zero), one) + tem = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) + tem1 = (tem - u10min) / (u10max - u10min) + tem2 = one - min(max(tem1, zero), one) + hffac(i) = tem2 * hffac(i) + hefac(i) = one + e0fac * hffac(i) + hffac(i) = one + hffac(i) + hflxq(i) = hflx(i) / hffac(i) + evapq(i) = evap(i) / hefac(i) + enddo + endif + + end subroutine GFS_surface_generic_post_run + + end module GFS_surface_generic_post diff --git a/physics/debug/GFS_surface_generic.meta_dbg b/physics/debug/GFS_surface_generic.meta_dbg new file mode 100644 index 000000000..5df487194 --- /dev/null +++ b/physics/debug/GFS_surface_generic.meta_dbg @@ -0,0 +1,1354 @@ +[ccpp-table-properties] + name = GFS_surface_generic_pre + type = scheme + dependencies = machine.F,surface_perturbation.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[levs] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[vfrac] + standard_name = vegetation_area_fraction + long_name = areal fractional cover of green vegetation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[stype] + standard_name = soil_type_classification_real + long_name = soil type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vtype] + standard_name = vegetation_type_classification_real + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[slope] + standard_name = surface_slope_classification_real + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsik_1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at lowest model interface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslk_1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at lowest model layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = inout + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = inout + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[slopetyp] + standard_name = surface_slope_classification + long_name = surface slope type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = inout + optional = F +[work3] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration + long_name = surface skin temperature after iteration + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zlvl] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drain_cpl] + standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling + long_name = change in rain_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[dsnow_cpl] + standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling + long_name = change in show_cpl (coupling_type) + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[rain_cpl] + standard_name = lwe_thickness_of_precipitation_amount_for_coupling + long_name = total rain precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snow_cpl] + standard_name = lwe_thickness_of_snow_amount_for_coupling + long_name = total snow precipitation + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lndp_type] + standard_name = index_for_stochastic_land_surface_perturbation_type + long_name = index for stochastic land surface perturbations type + units = index + dimensions = () + type = integer + intent = in + optional = F +[n_var_lndp] + standard_name = number_of_land_surface_variables_perturbed + long_name = number of land surface variables perturbed + units = count + dimensions = () + type = integer + intent = in + optional = F +[sfc_wts] + standard_name = weights_for_stochastic_surface_physics_perturbation + long_name = weights for stochastic surface physics perturbation + units = none + dimensions = (horizontal_loop_extent,number_of_land_surface_variables_perturbed) + type = real + kind = kind_phys + intent = in + optional = F +[sfc_wts_inv] + standard_name = weights_for_stochastic_surface_physics_perturbation_flipped + long_name = weights for stochastic surface physics perturbation, flipped + units = none + dimensions = (horizontal_loop_extent,number_of_land_surface_variables_perturbed) + type = real + kind = kind_phys + intent = inout + optional = F +[lndp_prt_list] + standard_name = magnitude_of_perturbations_for_landperts + long_name = magnitude of perturbations for landperts + units = variable + dimensions = (number_of_land_surface_variables_perturbed) + type = real + kind = kind_phys + intent = in + optional = F +[lndp_var_list] + standard_name = variables_to_be_perturbed_for_landperts + long_name = variables to be perturbed for landperts + units = none + dimensions = (number_of_land_surface_variables_perturbed) + type = character + kind = len=3 + intent = in + optional = F +[z01d] + standard_name = perturbation_of_momentum_roughness_length + long_name = perturbation of momentum roughness length + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[zt1d] + standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio + long_name = perturbation of heat to momentum roughness length ratio + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[bexp1d] + standard_name = perturbation_of_soil_type_b_parameter + long_name = perturbation of soil type "b" parameter + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[xlai1d] + standard_name = perturbation_of_leaf_area_index + long_name = perturbation of leaf area index + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[vegf1d] + standard_name = perturbation_of_vegetation_fraction + long_name = perturbation of vegetation fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[lndp_vgf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[flag_cice] + standard_name = flag_for_cice + long_name = flag for cice + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F +[slimskin_cpl] + standard_name = sea_land_ice_mask_in + long_name = sea/land/ice mask input (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cnvwind] + standard_name = surface_wind_enhancement_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold (volumetric) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-table-properties] + name = GFS_surface_generic_post + type = scheme + dependencies = machine.F,surface_perturbation.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_post_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[cplflx] + standard_name = flag_for_flux_coupling + long_name = flag controlling cplflx collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[cplwav] + standard_name = flag_for_wave_coupling + long_name = flag controlling cplwav collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ep1d] + standard_name = surface_upward_potential_latent_heat_flux + long_name = surface upward potential latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[gflx] + standard_name = upward_heat_flux_in_soil + long_name = upward soil heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs_1] + standard_name = air_temperature_at_lowest_model_layer + long_name = mean temperature at lowest model layer + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs_1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ugrs_1] + standard_name = x_wind_at_lowest_model_layer + long_name = zonal wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs_1] + standard_name = y_wind_at_lowest_model_layer + long_name = meridional wind at lowest model layer + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcdlw] + standard_name = surface_downwelling_longwave_flux + long_name = surface downwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjnirbmd] + standard_name = surface_downwelling_direct_near_infrared_shortwave_flux + long_name = surface downwelling beam near-infrared shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjnirdfd] + standard_name = surface_downwelling_diffuse_near_infrared_shortwave_flux + long_name = surface downwelling diffuse near-infrared shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjvisbmd] + standard_name = surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux + long_name = surface downwelling beam ultraviolet plus visible shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjvisdfd] + standard_name = surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux + long_name = surface downwelling diffuse ultraviolet plus visible shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw] + standard_name = surface_upwelling_longwave_flux + long_name = surface upwelling longwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjsfculw_wat] + standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial + long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjnirbmu] + standard_name = surface_upwelling_direct_near_infrared_shortwave_flux + long_name = surface upwelling beam near-infrared shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjnirdfu] + standard_name = surface_upwelling_diffuse_near_infrared_shortwave_flux + long_name = surface upwelling diffuse near-infrared shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjvisbmu] + standard_name = surface_upwelling_direct_ultraviolet_and_visible_shortwave_flux + long_name = surface upwelling beam ultraviolet plus visible shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[adjvisdfu] + standard_name = surface_upwelling_diffuse_ultraviolet_and_visible_shortwave_flux + long_name = surface upwelling diffuse ultraviolet plus visible shortwave flux at current time + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[t2m] + standard_name = temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q2m] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface skin temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc_wat] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[pgr] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xcosz] + standard_name = instantaneous_cosine_of_zenith_angle + long_name = cosine of zenith angle at current time + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[trans] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sbsno] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[epi] + standard_name = instantaneous_surface_potential_evaporation + long_name = instantaneous sfc potential evaporation + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gfluxi] + standard_name = instantaneous_surface_ground_heat_flux + long_name = instantaneous sfc ground heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer_for_diag + long_name = layer 1 temperature for diag + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer_for_diag + long_name = layer 1 specific humidity for diag + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer_for_diag + long_name = layer 1 x wind for diag + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer_for_diag + long_name = layer 1 y wind for diag + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dlwsfci_cpl] + standard_name = instantaneous_surface_downwelling_longwave_flux_for_coupling + long_name = instantaneous sfc downward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dswsfci_cpl] + standard_name = instantaneous_surface_downwelling_shortwave_flux_for_coupling + long_name = instantaneous sfc downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dlwsfc_cpl] + standard_name = cumulative_surface_downwelling_longwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc downward lw flux mulitplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dswsfc_cpl] + standard_name = cumulative_surface_downwelling_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dnirbmi_cpl] + standard_name = instantaneous_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling + long_name = instantaneous sfc nir beam downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dnirdfi_cpl] + standard_name = instantaneous_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling + long_name = instantaneous sfc nir diff downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dvisbmi_cpl] + standard_name = instantaneous_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling + long_name = instantaneous sfc uv+vis beam downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dvisdfi_cpl] + standard_name = instantaneous_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling + long_name = instantaneous sfc uv+vis diff downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dnirbm_cpl] + standard_name = cumulative_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc nir beam downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dnirdf_cpl] + standard_name = cumulative_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc nir diff downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dvisbm_cpl] + standard_name = cumulative_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc uv+vis beam dnwd sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[dvisdf_cpl] + standard_name = cumulative_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative sfc uv+vis diff dnwd sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nlwsfci_cpl] + standard_name = instantaneous_surface_net_downward_longwave_flux_for_coupling + long_name = instantaneous net sfc downward lw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nlwsfc_cpl] + standard_name = cumulative_surface_net_downward_longwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net downward lw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[t2mi_cpl] + standard_name = instantaneous_temperature_at_2m_for_coupling + long_name = instantaneous T2m + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[q2mi_cpl] + standard_name = instantaneous_specific_humidity_at_2m_for_coupling + long_name = instantaneous Q2m + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[u10mi_cpl] + standard_name = instantaneous_x_wind_at_10m_for_coupling + long_name = instantaneous U10m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[v10mi_cpl] + standard_name = instantaneous_y_wind_at_10m_for_coupling + long_name = instantaneous V10m + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsfci_cpl] + standard_name = instantaneous_surface_skin_temperature_for_coupling + long_name = instantaneous sfc temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[psurfi_cpl] + standard_name = instantaneous_surface_air_pressure_for_coupling + long_name = instantaneous sfc pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nnirbmi_cpl] + standard_name = instantaneous_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling + long_name = instantaneous net nir beam sfc downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nnirdfi_cpl] + standard_name = instantaneous_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling + long_name = instantaneous net nir diff sfc downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nvisbmi_cpl] + standard_name = instantaneous_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling + long_name = instantaneous net uv+vis beam downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nvisdfi_cpl] + standard_name = instantaneous_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling + long_name = instantaneous net uv+vis diff downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nswsfci_cpl] + standard_name = instantaneous_surface_net_downward_shortwave_flux_for_coupling + long_name = instantaneous net sfc downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nswsfc_cpl] + standard_name = cumulative_surface_net_downward_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nnirbm_cpl] + standard_name = cumulative_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net nir beam downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nnirdf_cpl] + standard_name = cumulative_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net nir diff downward sw flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nvisbm_cpl] + standard_name = cumulative_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net uv+vis beam downward sw rad flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[nvisdf_cpl] + standard_name = cumulative_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep + long_name = cumulative net uv+vis diff downward sw rad flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflux] + standard_name = cumulative_surface_ground_heat_flux_multiplied_by_timestep + long_name = cumulative groud conductive heat flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evbsa] + standard_name = cumulative_soil_upward_latent_heat_flux_multiplied_by_timestep + long_name = cumulative soil upward latent heat flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evcwa] + standard_name = cumulative_canopy_upward_latent_heat_flu_multiplied_by_timestep + long_name = cumulative canopy upward latent heat flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[transa] + standard_name = cumulative_transpiration_flux_multiplied_by_timestep + long_name = cumulative total plant transpiration rate multiplied by timestep + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sbsnoa] + standard_name = cumulative_snow_deposition_sublimation_upward_latent_heat_flux_multiplied_by_timestep + long_name = cumulative latent heat flux from snow depo/subl multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowca] + standard_name = cumulative_surface_snow_area_fraction_multiplied_by_timestep + long_name = cumulative surface snow area fraction multiplied by timestep + units = s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snohfa] + standard_name = cumulative_snow_freezing_rain_upward_latent_heat_flux_multiplied_by_timestep + long_name = cumulative latent heat flux due to snow and frz rain multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = cumulative_surface_upward_potential_latent_heat_flux_multiplied_by_timestep + long_name = cumulative surface upward potential latent heat flux multiplied by timestep + units = W m-2 s + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff] + standard_name = total_runoff + long_name = total water runoff + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[srunoff] + standard_name = surface_runoff + long_name = surface water runoff (from lsm) + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runof] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[z0fac] + standard_name = surface_roughness_fraction_factor + long_name = surface roughness fraction factor for canopy heat storage parameterization + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[e0fac] + standard_name = latent_heat_flux_fraction_factor_relative_to_sensible_heat_flux + long_name = latent heat flux fraction factor relative to sensible heat flux for canopy heat storage parameterization + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux + long_name = kinematic surface upward sensible heat flux + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[hflxq] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness + long_name = kinematic surface upward sensible heat flux reduced by surface roughness + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[evapq] + standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + long_name = kinematic surface upward latent heat flux reduced by surface roughness + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[hefac] + standard_name = surface_upward_latent_heat_flux_reduction_factor + long_name = surface upward latent heat flux reduction factor from canopy heat storage + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[hffac] + standard_name = surface_upward_sensible_heat_flux_reduction_factor + long_name = surface upward sensible heat flux reduction factor from canopy heat storage + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/debug/sfc_diff.f_dbg b/physics/debug/sfc_diff.f_dbg new file mode 100644 index 000000000..269a58637 --- /dev/null +++ b/physics/debug/sfc_diff.f_dbg @@ -0,0 +1,779 @@ +!> \file sfc_diff.f +!! This file contains the surface roughness length formulation based on +!! the surface sublayer scheme in +!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998. + +!> This module contains the CCPP-compliant GFS surface layer scheme. + module sfc_diff + + use machine , only : kind_phys + + implicit none + + public :: sfc_diff_init, sfc_diff_run, sfc_diff_finalize + + private + + real (kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant + + contains + + subroutine sfc_diff_init + end subroutine sfc_diff_init + + subroutine sfc_diff_finalize + end subroutine sfc_diff_finalize + +!> \defgroup GFS_diff_main GFS Surface Layer Scheme Module +!> @{ +!> \brief This subroutine calculates surface roughness length. +!! +!! This subroutine includes the surface roughness length formulation +!! based on the surface sublayer scheme in +!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998. +!> \section arg_table_sfc_diff_run Argument Table +!! \htmlinclude sfc_diff_run.html +!! +!> \section general_diff GFS Surface Layer Scheme General Algorithm +!! - Calculate the thermal roughness length formulation over the ocean (see eq. (25) and (26) +!! in Zeng et al. (1998) \cite zeng_et_al_1998). +!! - Calculate Zeng's momentum roughness length formulation over land and sea ice. +!! - Calculate the new vegetation-dependent formulation of thermal roughness length +!! (Zheng et al.(2009) \cite zheng_et_al_2009). +!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation on +!! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows: +!! \f[ +!! ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5} +!! \f] +!! where \f$Z_{0m}^,\f$ is the effective momentum roughness length +!! computed in the following equation for each grid, \f$Z_{0t}\f$ +!! is the roughness lenghth for heat, \f$C_{zil}\f$ is a coefficient +!! (taken as 0.8), k is the Von Karman constant (0.4), +!! \f$\nu=1.5\times10^{-5}m^{2}s^{-1}\f$ is the molecular viscosity, +!! \f$u*\f$ is the friction velocity, and \f$Z_{0g}\f$ is the bare +!! soil roughness length for momentum (taken as 0.01). +!! \n In order to consider the convergence of \f$Z_{0m}\f$ between +!! fully vegetated and bare soil, the effective \f$Z_{0m}^,\f$ is +!! computed: +!! \f[ +!! \ln(Z_{0m}^,)=(1-GVF)^{2}\ln(Z_{0g})+\left[1-(1-GVF)^{2}\right]\ln(Z_{0m}) +!!\f] +!! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes. +!! + subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) + & ps,t1,q1,z1,wind, & !intent(in) + & prsl1,prslki,prsik1,prslk1, & !intent(in) + & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) + & z0pert,ztpert, & ! mg, sfc-perts !intent(in) + & flag_iter,redrag, & !intent(in) + & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) + & wet,dry,icy, & !intent(in) + & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) + & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) + & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) + & lprnt, ipr, kdt, & ! intent(in) + & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) + & z0rl_wav, & !intent(inout) + & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) + & cm_wat, cm_lnd, cm_ice, & !intent(inout) + & ch_wat, ch_lnd, ch_ice, & !intent(inout) + & rb_wat, rb_lnd, rb_ice, & !intent(inout) + & stress_wat,stress_lnd,stress_ice, & !intent(inout) + & fm_wat, fm_lnd, fm_ice, & !intent(inout) + & fh_wat, fh_lnd, fh_ice, & !intent(inout) + & fm10_wat, fm10_lnd, fm10_ice, & !intent(inout) + & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) + & errmsg, errflg) !intent(out) +! + implicit none +! + integer, parameter :: kp = kind_phys + integer, intent(in) :: im, ivegsrc, kdt, ipr + integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean + + integer, dimension(im), intent(in) :: vegtype + + logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) + logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy + logical, intent(in) :: lprnt + + real(kind=kind_phys), dimension(im), intent(in) :: u10m,v10m + real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav + real(kind=kind_phys), dimension(im), intent(in) :: & + & ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & + & wind,sigmaf,shdmax, & + & z0pert,ztpert ! mg, sfc-perts + real(kind=kind_phys), dimension(im), intent(in) :: & + & tskin_wat, tskin_lnd, tskin_ice, & + & tsurf_wat, tsurf_lnd, tsurf_ice, & + & snwdph_wat,snwdph_lnd,snwdph_ice + + real(kind=kind_phys), dimension(im), intent(in) :: z0rl_wav + real(kind=kind_phys), dimension(im), intent(inout) :: & + & z0rl_wat, z0rl_lnd, z0rl_ice, & + & ustar_wat, ustar_lnd, ustar_ice, & + & cm_wat, cm_lnd, cm_ice, & + & ch_wat, ch_lnd, ch_ice, & + & rb_wat, rb_lnd, rb_ice, & + & stress_wat,stress_lnd,stress_ice, & + & fm_wat, fm_lnd, fm_ice, & + & fh_wat, fh_lnd, fh_ice, & + & fm10_wat, fm10_lnd, fm10_ice, & + & fh2_wat, fh2_lnd, fh2_ice + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg +! +! locals +! + integer i +! + real(kind=kind_phys) :: rat, thv1, restar, wind10m, + & czilc, tem1, tem2, virtfac + + real(kind=kind_phys) :: tvs, z0, z0max, ztmax +! + real(kind=kind_phys), parameter :: + & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp + &, charnock=.014_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea + &, zmin=1.0e-6_kp & + &, vis=1.4e-5_kp, rnu=1.51e-5_kp, visi=one/vis & + &, log01=log(0.01_kp), log05=log(0.05_kp), log07=log(0.07_kp) + +! parameter (charnock=.014,ca=.4)!c ca is the von karman constant +! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) +! parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5) + +! real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu +! parameter (aa1=-1.076,bb1=.7045,cc1=-.05808) +! parameter (bb2=-.1954,cc2=.009999) +! parameter (arnu=.135*rnu) +! +! z0s_max=.196e-2 for u10_crit=25 m/s +! z0s_max=.317e-2 for u10_crit=30 m/s +! z0s_max=.479e-2 for u10_crit=35 m/s +! +! mbek -- toga-coare flux algorithm +! parameter (rnu=1.51e-5,arnu=0.11*rnu) + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! initialize variables. all units are supposedly m.k.s. unless specified +! ps is in pascals, wind is wind speed, +! surface roughness length is converted to m from cm +! + +! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + + do i=1,im + if(flag_iter(i)) then + virtfac = one + rvrdm1 * max(q1(i),qmin) + thv1 = t1(i) * prslki(i) * virtfac + +! compute stability dependent exchange coefficients +! this portion of the code is presently suppressed +! + if (dry(i)) then ! Some land +#ifdef GSD_SURFACE_FLUXES_BUGFIX + tvs = half * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) + & * virtfac +#else + tvs = half * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac +#endif + z0max = max(zmin, min(0.01_kp * z0rl_lnd(i), z1(i))) +!** xubin's new z0 over land + tem1 = one - shdmax(i) + tem2 = tem1 * tem1 + tem1 = one - tem2 + + if( ivegsrc == 1 ) then + + if (vegtype(i) == 10) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 6) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 7) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01_kp + elseif (vegtype(i) == 16) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01_kp + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + elseif (ivegsrc == 2 ) then + + if (vegtype(i) == 7) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01_kp + elseif (vegtype(i) == 11) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01_kp + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + endif +! mg, sfc-perts: add surface perturbations to z0max over land + if (z0pert(i) /= zero ) then + z0max = z0max * (10.0_kp**z0pert(i)) + endif + + z0max = max(z0max, zmin) + +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil + czilc = 0.8_kp + + tem1 = 1.0_kp - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) + + +! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land + if (ztpert(i) /= zero) then + ztmax = ztmax * (10.0_kp**ztpert(i)) + endif + ztmax = max(ztmax, zmin) +! + if(lprnt .and. i == ipr) write(0,*)' z1=',z1(i),' snwdph_lnd=', & + &snwdph_lnd(i),' thv1=',thv1,' wind=',wind(i),' z0max=',z0max, & + &' ztmax=',ztmax,' tvs=',tvs + call stability +! --- inputs: + & (z1(i), snwdph_lnd(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, +! --- outputs: + & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), + & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + endif ! Dry points + if(lprnt .and. i == ipr) write(0,*)'cm_lnd=',cm_lnd(i),' kdt=',kdt& + &,' ch_lnd=',ch_lnd(i),' ustar_lnd=',ustar_lnd(i) + + if (icy(i)) then ! Some ice + tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac + z0max = max(zmin, min(0.01_kp * z0rl_ice(i), z1(i))) +!** xubin's new z0 over land and sea ice + tem1 = one - shdmax(i) + tem2 = tem1 * tem1 + tem1 = one - tem2 + + if( ivegsrc == 1 ) then + + z0max = exp( tem2*log01 + tem1*log(z0max) ) + elseif (ivegsrc == 2 ) then + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + z0max = max(z0max, zmin) + +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height +! dependance of czil + czilc = 0.8_kp + + tem1 = 1.0_kp - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) + ztmax = max(ztmax, 1.0e-6) +! + call stability +! --- inputs: + & (z1(i), snwdph_ice(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, +! --- outputs: + & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), + & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) + endif ! Icy points + +! BWG: Everything from here to end of subroutine was after +! the stuff now put into "stability" + + if (wet(i)) then ! Some open ocean + tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac + z0 = 0.01_kp * z0rl_wat(i) + z0max = max(zmin, min(z0,z1(i))) + ustar_wat(i) = sqrt(grav * z0 / charnock) + wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) + +!** test xubin's new z0 + +! ztmax = z0max + + restar = max(ustar_wat(i)*z0max*visi, 0.000001_kp) + +! restar = log(restar) +! restar = min(restar,5.) +! restar = max(restar,-5.) +! rat = aa1 + (bb1 + cc1*restar) * restar +! rat = rat / (1. + (bb2 + cc2*restar) * restar)) +! rat taken from zeng, zhao and dickinson 1997 + + rat = min(7.0_kp, 2.67_kp * sqrt(sqrt(restar)) - 2.57_kp) + ztmax = max(z0max * exp(-rat), zmin) +! + if (sfc_z0_type == 6) then + call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type == 7) then + call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) + else if (sfc_z0_type > 0) then + write(0,*)'no option for sfc_z0_type=',sfc_z0_type + stop + endif +! + call stability +! --- inputs: + & (z1(i), snwdph_wat(i), thv1, wind(i), + & z0max, ztmax, tvs, grav, +! --- outputs: + & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), + & cm_wat(i), ch_wat(i), stress_wat(i), ustar_wat(i)) +! +! update z0 over ocean +! + if (sfc_z0_type >= 0) then + if (sfc_z0_type == 0) then + z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + +! mbek -- toga-coare flux algorithm +! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) +! new implementation of z0 +! cc = ustar(i) * z0 / rnu +! pp = cc / (1. + cc) +! ff = grav * arnu / (charnock * ustar(i) ** 3) +! z0 = arnu / (ustar(i) * ff ** pp) + + if (redrag) then + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max), & + & 1.0e-7_kp) + else + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.e-7_kp) + endif + + elseif (sfc_z0_type == 6) then ! wang + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl_wat(i) = 100.0_kp * z0 ! cm + elseif (sfc_z0_type == 7) then ! wang + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl_wat(i) = 100.0_kp * z0 ! cm + else + z0rl_wat(i) = 1.0e-4_kp + endif + + elseif (z0rl_wav(i) <= 1.0e-7_kp) then + z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + + if (redrag) then + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) + else + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) + endif + endif + + endif ! end of if(open ocean) +! + endif ! end of if(flagiter) loop + enddo + + return + end subroutine sfc_diff_run +!> @} + +!---------------------------------------- +!>\ingroup GFS_diff_main + subroutine stability & +! --- inputs: + & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & +! --- outputs: + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) +!----- + + integer, parameter :: kp = kind_phys +! --- inputs: + real(kind=kind_phys), intent(in) :: & + & z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav + +! --- outputs: + real(kind=kind_phys), intent(out) :: & + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar + +! --- locals: + real(kind=kind_phys), parameter :: alpha=5.0_kp, a0=-3.975_kp & + &, a1=12.32_kp, alpha4=4.0_kp*alpha & + &, b1=-7.755_kp, b2=6.041_kp, alpha2=alpha+alpha & + &, beta=1.0_kp & + &, a0p=-7.941_kp, a1p=24.75_kp, b1p=-8.705_kp, b2p=7.899_kp& + &, ztmin1=-999.0_kp, zero=0.0_kp, one=1.0_kp + + real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, + & hl1, hl12, pm, ph, pm10, ph2, + & z1i, + & fms, fhs, hl0, hl0inf, hlinf, + & hl110, hlt, hltinf, olinf, + & tem1, tem2, ztmax1 + + z1i = one / z1 + + tem1 = z0max/z1 + if (abs(one-tem1) > 1.0e-6_kp) then + ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) + else + ztmax1 = 99.0_kp + endif + if( z0max < 0.05_kp .and. snwdph < 10.0_kp ) ztmax1 = 99.0_kp + +! compute stability indices (rb and hlinf) + + dtv = thv1 - tvs + adtv = max(abs(dtv),0.001_kp) + dtv = sign(1.,dtv) * adtv +#ifdef GSD_SURFACE_FLUXES_BUGFIX + rb = max(-5000.0_kp, grav * dtv * z1 + & / (thv1 * wind * wind)) +#else + rb = max(-5000.0_kp, (grav+grav) * dtv * z1 + & / ((thv1 + tvs) * wind * wind)) +#endif + tem1 = one / z0max + tem2 = one / ztmax + fm = log((z0max+z1) * tem1) + fh = log((ztmax+z1) * tem2) + fm10 = log((z0max+10.0_kp) * tem1) + fh2 = log((ztmax+2.0_kp) * tem2) + hlinf = rb * fm * fm / fh + hlinf = min(max(hlinf,ztmin1),ztmax1) +! +! stable case +! + if (dtv >= zero) then + hl1 = hlinf + if(hlinf > 0.25_kp) then + tem1 = hlinf * z1i + hl0inf = z0max * tem1 + hltinf = ztmax * tem1 + aa = sqrt(one + alpha4 * hlinf) + aa0 = sqrt(one + alpha4 * hl0inf) + bb = aa + bb0 = sqrt(one + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) + ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) + fms = fm - pm + fhs = fh - ph + hl1 = fms * fms * rb / fhs + hl1 = min(max(hl1, ztmin1), ztmax1) + endif +! +! second iteration +! + tem1 = hl1 * z1i + hl0 = z0max * tem1 + hlt = ztmax * tem1 + aa = sqrt(one + alpha4 * hl1) + aa0 = sqrt(one + alpha4 * hl0) + bb = aa + bb0 = sqrt(one + alpha4 * hlt) + pm = aa0 - aa + log( (one+aa)/(one+aa0) ) + ph = bb0 - bb + log( (one+bb)/(one+bb0) ) + hl110 = hl1 * 10.0_kp * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + aa = sqrt(one + alpha4 * hl110) + pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12,ztmin1),ztmax1) +! aa = sqrt(one + alpha4 * hl12) + bb = sqrt(one + alpha4 * hl12) + ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) +! +! unstable case - check for unphysical obukhov length +! + else ! dtv < 0 case + olinf = z1 / hlinf + tem1 = 50.0_kp * z0max + if(abs(olinf) <= tem1) then + hlinf = -z1 / tem1 + hlinf = min(max(hlinf,ztmin1),ztmax1) + endif +! +! get pm and ph +! + if (hlinf >= -0.5_kp) then + hl1 = hlinf + pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10.0_kp * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) + else ! hlinf < 0.05 + hl1 = -hlinf + tem1 = one / sqrt(hl1) + pm = log(hl1) + 2.0_kp * sqrt(tem1) - .8776_kp + ph = log(hl1) + 0.5_kp * tem1 + 1.386_kp +! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 +! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 + hl110 = hl1 * 10.0_kp * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp +! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp +! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 + endif + + endif ! end of if (dtv >= 0 ) then loop +! +! finish the exchange coefficient computation to provide fm and fh +! + fm = fm - pm + fh = fh - ph + fm10 = fm10 - pm10 + fh2 = fh2 - ph2 + cm = ca * ca / (fm * fm) + ch = ca * ca / (fm * fh) + tem1 = 0.00001_kp/z1 + cm = max(cm, tem1) + ch = max(ch, tem1) + stress = cm * wind * wind + ustar = sqrt(stress) + + return +!................................. + end subroutine stability +!--------------------------------- + + +!! add fitted z0,zt curves for hurricane application (used in HWRF/HMON) +!! Weiguo Wang, 2019-0425 + + SUBROUTINE znot_m_v6(uref, znotm) + use machine , only : kind_phys + IMPLICIT NONE +! Calculate areodynamical roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) +! For high winds, try to fit available observational data +! +! Bin Liu, NOAA/NCEP/EMC 2017 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, + & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, + & p10 = -8.396975715683501e+00, + + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, + + & p35 = 1.840430200185075e-07, p34 = -2.793849676757154e-05, + & p33 = 1.735308193700643e-03, p32 = -6.139315534216305e-02, + & p31 = 1.255457892775006e+00, p30 = -1.663993561652530e+01, + + & p40 = 4.579369142033410e-04 + + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp(p10 + uref * (p11 + uref * (p12 + uref*p13))) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35))))) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_m_v6 + + SUBROUTINE znot_t_v6(uref, znott) + use machine , only : kind_phys + IMPLICIT NONE +! Calculate scalar roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm +! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF +! +! Bin Liu, NOAA/NCEP/EMC 2017 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znott + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, + & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08, + & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05, + & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04, + + & p25 = -8.654513012535990e-12, p24 = 1.232380050058077e-09, + & p23 = -6.837922749505057e-08, p22 = 1.871407733439947e-06, + & p21 = -2.552246987137160e-05, p20 = 1.428968311457630e-04, + + & p35 = 3.207515102100162e-12, p34 = -2.945761895342535e-10, + & p33 = 8.788972147364181e-09, p32 = -3.814457439412957e-08, + & p31 = -2.448983648874671e-06, p30 = 3.436721779020359e-05, + + & p45 = -3.530687797132211e-11, p44 = 3.939867958963747e-09, + & p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05, + & p41 = 5.988240863928883e-04, p40 = -7.746288511324971e-03, + + & p56 = -1.187982453329086e-13, p55 = 4.801984186231693e-11, + & p54 = -8.049200462388188e-09, p53 = 7.169872601310186e-07, + & p52 = -3.581694433758150e-05, p51 = 9.503919224192534e-04, + & p50 = -1.036679430885215e-02, + + & p60 = 4.751256171799112e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 + & + uref * (p14 + uref * p15)))) + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 21.6 .and. uref <= 42.2) then + znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35)))) + elseif ( uref > 42.2 .and. uref <= 53.3) then + znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 + & + uref * (p44 + uref * p45)))) + elseif ( uref > 53.3 .and. uref <= 80.0) then + znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 + & + uref * (p54 + uref * (p55 + uref * p56))))) + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_t_v6 + + + SUBROUTINE znot_m_v7(uref, znotm) + use machine , only : kind_phys + IMPLICIT NONE +! Calculate areodynamical roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) +! For high winds, try to fit available observational data +! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znotm(meter): areodynamical roughness scale over water +! + + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znotm + + real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, + & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, + & p10 = -8.396975715683501e+00, + + & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, + & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, + & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, + + & p35 = 1.897534489606422e-07, p34 = -3.019495980684978e-05, + & p33 = 1.931392924987349e-03, p32 = -6.797293095862357e-02, + & p31 = 1.346757797103756e+00, p30 = -1.707846930193362e+01, + + & p40 = 3.371427455376717e-04 + + if (uref >= 0.0 .and. uref <= 6.5 ) then + znotm = exp( p10 + uref * (p11 + uref * (p12 + uref * p13))) + elseif (uref > 6.5 .and. uref <= 15.7) then + znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 15.7 .and. uref <= 53.0) then + znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35))))) + elseif ( uref > 53.0) then + znotm = p40 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_m_v7 + SUBROUTINE znot_t_v7(uref, znott) + use machine , only : kind_phys + IMPLICIT NONE +! Calculate scalar roughness over water with input 10-m wind +! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm +! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF +! To be compatible with the slightly decreased Cd for higher wind speed +! +! Bin Liu, NOAA/NCEP/EMC 2018 +! +! uref(m/s) : wind speed at 10-m height +! znott(meter): scalar roughness scale over water +! + + REAL(kind=kind_phys), INTENT(IN) :: uref + REAL(kind=kind_phys), INTENT(OUT):: znott + + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, + + & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08, + & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05, + & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04, + + & p25 = -9.402722450219142e-12, p24 = 1.325396583616614e-09, + & p23 = -7.299148051141852e-08, p22 = 1.982901461144764e-06, + & p21 = -2.680293455916390e-05, p20 = 1.484341646128200e-04, + + & p35 = 7.921446674311864e-12, p34 = -1.019028029546602e-09, + & p33 = 5.251986927351103e-08, p32 = -1.337841892062716e-06, + & p31 = 1.659454106237737e-05, p30 = -7.558911792344770e-05, + + & p45 = -2.694370426850801e-10, p44 = 5.817362913967911e-08, + & p43 = -5.000813324746342e-06, p42 = 2.143803523428029e-04, + & p41 = -4.588070983722060e-03, p40 = 3.924356617245624e-02, + + & p56 = -1.663918773476178e-13, p55 = 6.724854483077447e-11, + & p54 = -1.127030176632823e-08, p53 = 1.003683177025925e-06, + & p52 = -5.012618091180904e-05, p51 = 1.329762020689302e-03, + & p50 = -1.450062148367566e-02, p60 = 6.840803042788488e-05 + + if (uref >= 0.0 .and. uref < 5.9 ) then + znott = p00 + elseif (uref >= 5.9 .and. uref <= 15.4) then + znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 + & + uref * (p14 + uref * p15)))) + elseif (uref > 15.4 .and. uref <= 21.6) then + znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 + & + uref * (p24 + uref * p25)))) + elseif (uref > 21.6 .and. uref <= 42.6) then + znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 + & + uref * (p34 + uref * p35)))) + elseif ( uref > 42.6 .and. uref <= 53.0) then + znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 + & + uref * (p44 + uref * p45)))) + elseif ( uref > 53.0 .and. uref <= 80.0) then + znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 + & + uref * (p54 + uref * (p55 + uref * p56))))) + elseif ( uref > 80.0) then + znott = p60 + else + print*, 'Wrong input uref value:',uref + endif + + END SUBROUTINE znot_t_v7 + + +!--------------------------------- + end module sfc_diff diff --git a/physics/debug/sfc_diff.meta_dbg b/physics/debug/sfc_diff.meta_dbg new file mode 100644 index 000000000..7eda0c7d4 --- /dev/null +++ b/physics/debug/sfc_diff.meta_dbg @@ -0,0 +1,653 @@ +[ccpp-table-properties] + name = sfc_diff + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = sfc_diff_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = 1st model layer specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[z1] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsik1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at the ground surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslk1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at the lowest model layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractnl cover of green veg + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[z0pert] + standard_name = perturbation_of_momentum_roughness_length + long_name = perturbation of momentum roughness length + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ztpert] + standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio + long_name = perturbation of heat to momentum roughness length ratio + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[redrag] + standard_name = flag_for_reduced_drag_coefficient_over_sea + long_name = flag for reduced drag coefficient over sea + units = flag + dimensions = () + type = logical + intent = in + optional = F +[u10m] + standard_name = x_wind_at_10m + long_name = 10 meter u wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v10m] + standard_name = y_wind_at_10m + long_name = 10 meter v wind speed + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfc_z0_type] + standard_name = flag_for_surface_roughness_option_over_ocean + long_name = surface roughness options over ocean + units = flag + dimensions = () + type = integer + intent = in + optional = F +[wet] + standard_name = flag_nonzero_wet_surface_fraction + long_name = flag indicating presence of some ocean or lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[tskin_wat] + standard_name = surface_skin_temperature_over_ocean_interstitial + long_name = surface skin temperature over ocean (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tskin_lnd] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tskin_ice] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_wat] + standard_name = surface_skin_temperature_after_iteration_over_ocean + long_name = surface skin temperature after iteration over ocean + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_lnd] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tsurf_ice] + standard_name = surface_skin_temperature_after_iteration_over_ice + long_name = surface skin temperature after iteration over ice + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph_wat] + standard_name = surface_snow_thickness_water_equivalent_over_ocean + long_name = water equivalent snow depth over ocean + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph_lnd] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snwdph_ice] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[z0rl_wat] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[z0rl_lnd] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[z0rl_ice] + standard_name = surface_roughness_length_over_ice_interstitial + long_name = surface roughness length over ice (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[z0rl_wav] + standard_name = surface_roughness_length_from_wave_model + long_name = surface roughness length from wave model + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ustar_wat] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_lnd] + standard_name = surface_friction_velocity_over_land + long_name = surface friction velocity over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ice] + standard_name = surface_friction_velocity_over_ice + long_name = surface friction velocity over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_wat] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean + long_name = surface exchange coeff for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_lnd] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_ice] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice + long_name = surface exchange coeff for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_wat] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean + long_name = surface exchange coeff heat & moisture over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_lnd] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ice] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice + long_name = surface exchange coeff heat & moisture over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_wat] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean + long_name = bulk Richardson number at the surface over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_lnd] + standard_name = bulk_richardson_number_at_lowest_model_level_over_land + long_name = bulk Richardson number at the surface over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_ice] + standard_name = bulk_richardson_number_at_lowest_model_level_over_ice + long_name = bulk Richardson number at the surface over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_wat] + standard_name = surface_wind_stress_over_ocean + long_name = surface wind stress over ocean + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_lnd] + standard_name = surface_wind_stress_over_land + long_name = surface wind stress over land + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ice] + standard_name = surface_wind_stress_over_ice + long_name = surface wind stress over ice + units = m2 s-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_wat] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean + long_name = Monin-Obukhov similarity function for momentum over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land + long_name = Monin-Obukhov similarity function for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice + long_name = Monin-Obukhov similarity function for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_wat] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean + long_name = Monin-Obukhov similarity function for heat over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_land + long_name = Monin-Obukhov similarity function for heat over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice + long_name = Monin-Obukhov similarity function for heat over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_wat] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_lnd] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land + long_name = Monin-Obukhov similarity parameter for momentum at 10m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ice] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice + long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_wat] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean + long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_lnd] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land + long_name = Monin-Obukhov similarity parameter for heat at 2m over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ice] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice + long_name = Monin-Obukhov similarity parameter for heat at 2m over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/debug/sfc_drv.f_dbg b/physics/debug/sfc_drv.f_dbg new file mode 100644 index 000000000..3c4a937db --- /dev/null +++ b/physics/debug/sfc_drv.f_dbg @@ -0,0 +1,666 @@ +!> \file sfc_drv.f +!! This file contains the Noah land surface scheme driver. + +!> This module contains the CCPP-compliant Noah land surface scheme driver. + module lsm_noah + + use machine, only: kind_phys + use set_soilveg_mod, only: set_soilveg + use namelist_soilveg + + implicit none + + private + + public :: lsm_noah_init, lsm_noah_run, lsm_noah_finalize + + contains + +!>\ingroup Noah_LSM +!! This subroutine contains the CCPP-compliant lsm_noah_init to initialize soil vegetation. +!! \section arg_table_lsm_noah_init Argument Table +!! \htmlinclude lsm_noah_init.html +!! + subroutine lsm_noah_init(me, isot, ivegsrc, nlunit, + & pores, resid, errmsg, errflg) + + implicit none + + integer, intent(in) :: me, isot, ivegsrc, nlunit + + real (kind=kind_phys), dimension(:), intent(out) :: pores, resid + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (ivegsrc > 2) then + errmsg = 'The NOAH LSM expects that the ivegsrc physics '// + & 'namelist parameter is 0, 1, or 2. Exiting...' + errflg = 1 + return + end if + if (isot > 1) then + errmsg = 'The NOAH LSM expects that the isot physics '// + & 'namelist parameter is 0, or 1. Exiting...' + errflg = 1 + return + end if + + !--- initialize soil vegetation + call set_soilveg(me, isot, ivegsrc, nlunit) + + pores (:) = maxsmc (:) + resid (:) = drysmc (:) + + end subroutine lsm_noah_init + + +!! \section arg_table_lsm_noah_finalize Argument Table +!! \htmlinclude lsm_noah_finalize.html +!! + subroutine lsm_noah_finalize(errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine lsm_noah_finalize + + +! ===================================================================== ! +! description: ! +! ! +! usage: ! +! ! +! call sfc_drv ! +! --- inputs: ! +! ( im, km, ps, t1, q1, soiltyp, vegtype, sigmaf, ! +! sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, ! +! prsl1, prslki, zf, land, wind, slopetyp, ! +! shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, ! +! lheatstrg, isot, ivegsrc, ! +! --- in/outs: ! +! weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, ! +! canopy, trans, tsurf, zorl, ! +! --- outputs: ! +! sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, ! +! cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, ! +! smcwlt2, smcref2, wet1 ) ! +! ! +! ! +! subprogram called: sflx ! +! ! +! program history log: ! +! xxxx -- created ! +! 200x -- sarah lu modified ! +! oct 2006 -- h. wei modified ! +! apr 2009 -- y.-t. hou modified to include surface emissivity ! +! effect on lw radiation. replaced the comfussing ! +! slrad (net sw + dlw) with sfc net sw snet=dsw-usw ! +! sep 2009 -- s. moorthi modification to remove rcl and unit change! +! nov 2011 -- sarah lu corrected wet1 calculation +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im - integer, horiz dimention and num of used pts 1 ! +! km - integer, vertical soil layer dimension 1 ! +! ps - real, surface pressure (pa) im ! +! t1 - real, surface layer mean temperature (k) im ! +! q1 - real, surface layer mean specific humidity im ! +! soiltyp - integer, soil type (integer index) im ! +! vegtype - integer, vegetation type (integer index) im ! +! sigmaf - real, areal fractional cover of green vegetation im ! +! sfcemis - real, sfc lw emissivity ( fraction ) im ! +! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! +! dswflx - real, total sky sfc downward sw flux ( w/m**2 ) im ! +! snet - real, total sky sfc netsw flx into ground(w/m**2) im ! +! delt - real, time interval (second) 1 ! +! tg3 - real, deep soil temperature (k) im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, sfc layer 1 mean pressure (pa) im ! +! prslki - real, dimensionless exner function at layer 1 im ! +! zf - real, height of bottom layer (m) im ! +! land - logical, = T if a point with any land im ! +! wind - real, wind speed (m/s) im ! +! slopetyp - integer, class of sfc slope (integer index) im ! +! shdmin - real, min fractional coverage of green veg im ! +! shdmax - real, max fractnl cover of green veg (not used) im ! +! snoalb - real, upper bound on max albedo over deep snow im ! +! sfalb - real, mean sfc diffused sw albedo (fractional) im ! +! flag_iter- logical, im ! +! flag_guess-logical, im ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! isot - integer, sfc soil type data source zobler or statsgo ! +! ivegsrc - integer, sfc veg type data source umd or igbp ! +! ! +! input/outputs: ! +! weasd - real, water equivalent accumulated snow depth (mm) im ! +! 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 ! +! smc - real, total soil moisture content (fractional) im,km ! +! stc - real, soil temp (k) im,km ! +! slc - real, liquid soil moisture im,km ! +! canopy - real, canopy moisture content (m) im ! +! trans - real, total plant transpiration (m/s) im ! +! tsurf - real, surface skin temperature (after iteration) im ! +! zorl - real, surface roughness im ! +! sncovr1 - real, snow cover over land (fractional) im ! +! qsurf - real, specific humidity at sfc im ! +! gflux - real, soil heat flux (w/m**2) im ! +! drain - real, subsurface runoff (mm/s) im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ep - real, potential evaporation im ! +! runoff - real, surface runoff (m/s) im ! +! cmm - real, im ! +! chh - real, im ! +! evbs - real, direct soil evaporation (m/s) im ! +! evcw - real, canopy water evaporation (m/s) im ! +! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! snowc - real, fractional snow cover im ! +! stm - real, total soil column moisture content (m) im ! +! snohf - real, snow/freezing-rain latent heat flux (w/m**2)im ! +! smcwlt2 - real, dry soil moisture threshold im ! +! smcref2 - real, soil moisture threshold im ! +! wet1 - real, normalized soil wetness im ! +! ! +! ==================== end of description ===================== ! + +!>\defgroup Noah_LSM GFS Noah LSM Model +!! \brief This is Noah LSM driver module, with the functionality of +!! preparing variables to run Noah LSM gfssflx(), calling Noah LSM and post-processing +!! variables for return to the parent model suite including unit conversion, as well +!! as diagnotics calculation. +!! \section arg_table_lsm_noah_run Argument Table +!! \htmlinclude lsm_noah_run.html +!! +!> \section general_noah_drv GFS sfc_drv General Algorithm +!> @{ + subroutine lsm_noah_run & + & ( im, km, grav, cp, hvap, rd, eps, epsm1, rvrdm1, ps, & ! --- inputs: + & t1, q1, soiltyp, vegtype, sigmaf, & + & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & prsl1, prslki, zf, land, wind, slopetyp, & + & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & lheatstrg, isot, ivegsrc, & + & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne + & lprnt, ipr, kdt, & +! --- in/outs: + & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & + & canopy, trans, tsurf, zorl, & +! --- outputs: + & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & + & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & + & smcwlt2, smcref2, wet1, errmsg, errflg & + & ) +! + !use machine , only : kind_phys + use funcphys, only : fpvs + + use surface_perturbation, only : ppfbet + + implicit none + +! --- constant parameters: + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: rhoh2o = 1000.0_kind_phys + real(kind=kind_phys), parameter :: a2 = 17.2693882_kind_phys + real(kind=kind_phys), parameter :: a3 = 273.16_kind_phys + real(kind=kind_phys), parameter :: a4 = 35.86_kind_phys + real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys + + real(kind=kind_phys), save :: zsoil_noah(4) + data zsoil_noah / -0.1_kind_phys, -0.4_kind_phys, & + & -1.0_kind_phys, -2.0_kind_phys / + +! --- input: + logical, intent(in) :: lprnt + integer, intent(in) :: im, km, isot, ivegsrc, ipr, kdt + real (kind=kind_phys), intent(in) :: grav, cp, hvap, rd, eps, & + & epsm1, rvrdm1 + real (kind=kind_phys), intent(in) :: pertvegf + + integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp + + real (kind=kind_phys), dimension(im), intent(in) :: ps, & + & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & + & ch, prsl1, prslki, wind, shdmin, shdmax, & + & snoalb, sfalb, zf, & + & bexppert, xlaipert, vegfpert + + real (kind=kind_phys), intent(in) :: delt + + logical, dimension(im), intent(in) :: flag_iter, flag_guess, land + + logical, intent(in) :: lheatstrg + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl + + real (kind=kind_phys), dimension(im,km), intent(inout) :: & + & smc, stc, slc + +! --- output: + real (kind=kind_phys), dimension(im), intent(inout) :: sncovr1, & + & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, & + & wet1 + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals: + real (kind=kind_phys), dimension(im) :: rch, rho, & + & q0, qs1, theta1, weasd_old, snwdph_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old + + real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & + & smsoil, slsoil + + real (kind=kind_phys), dimension(im,km) :: zsoil, smc_old, & + & stc_old, slc_old + + real (kind=kind_phys) :: alb, albedo, beta, chx, cmx, cmc, & + & dew, drip, dqsdt2, ec, edir, ett, eta, esnow, etp, & + & flx1, flx2, flx3, ffrozp, lwdn, pc, prcp, ptu, q2, & + & q2sat, solnet, rc, rcs, rct, rcq, rcsoil, rsmin, & + & runoff1, runoff2, runoff3, sfcspd, sfcprs, sfctmp, & + & sfcems, sheat, shdfac, shdmin1d, shdmax1d, smcwlt, & + & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & + & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, tbot, & + & xlai, zlvl, swdn, tem, z0, bexpp, xlaip, vegfp, & + & mv, sv, alphav, betav, vegftmp, cpinv, hvapi, elocp + + integer :: couple, ice, nsoil, nroot, slope, stype, vtype + integer :: i, k, iflag +! +!===> ... begin here +! + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp + +!> - Initialize CCPP error handling variables + + errmsg = '' + errflg = 0 + +!> - Save land-related prognostic fields for guess run. + + if (lprnt) write(0,*)' tkin at beg of sfc_drv ', tskin(ipr), & + &' kdt=',kdt,' land=',land(ipr),' flag_guess=',flag_guess(ipr) + do i = 1, im + if (land(i) .and. flag_guess(i)) then + weasd_old(i) = weasd(i) + snwdph_old(i) = snwdph(i) + tskin_old(i) = tskin(i) + canopy_old(i) = canopy(i) + tprcp_old(i) = tprcp(i) + srflag_old(i) = srflag(i) + + do k = 1, km + smc_old(i,k) = smc(i,k) + stc_old(i,k) = stc(i,k) + slc_old(i,k) = slc(i,k) + enddo + endif ! land & flag_guess + enddo + +! --- ... initialization block + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + ep(i) = zero + evap (i) = zero + hflx (i) = zero + gflux(i) = zero + drain(i) = zero + canopy(i) = max(canopy(i), zero) + + evbs (i) = zero + evcw (i) = zero + trans(i) = zero + sbsno(i) = zero + snowc(i) = zero + snohf(i) = zero + +!> - initialize variables wind, q, and rh at level 1. + + q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) + theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0(i))) + qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) + qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) + q0 (i) = min(qs1(i), q0(i)) + + do k = 1, km + zsoil(i,k) = zsoil_noah(k) + enddo + +!> - Prepare variables to run Noah LSM: +!! - 1. configuration information (c): +! couple couple-uncouple flag (=1: coupled, =0: uncoupled) +! ffrozp flag for snow-rain detection (1.=snow, 0.=rain) +! ice sea-ice flag (=1: sea-ice, =0: land) +! dt timestep (sec) (dt should not exceed 3600 secs) = delt +! zlvl height (\f$m\f$) above ground of atmospheric forcing variables +! nsoil number of soil layers (at least 2) +! sldpth the thickness of each soil layer (\f$m\f$) + + couple = 1 ! run noah lsm in 'couple' mode +! use srflag directly to allow fractional rain/snow +! if (srflag(i) == 1.0) then ! snow phase +! ffrozp = 1.0 +! elseif (srflag(i) == 0.0) then ! rain phase +! ffrozp = 0.0 +! endif + ffrozp = srflag(i) + ice = 0 + + zlvl = zf(i) + + nsoil = km + sldpth(1) = - zsoil(i,1) + do k = 2, km + sldpth(k) = zsoil(i,k-1) - zsoil(i,k) + enddo + +!> - 2. forcing data (f): +! lwdn lw dw radiation flux (\f$W m^{-2}\f$) +! solnet - net sw radiation flux (dn-up) (\f$W m^{-2}\f$) +! sfcprs - pressure at height zlvl above ground (pascals) +! prcp - precip rate (\f$kg m^{-2} s^{-1}\f$) +! sfctmp - air temperature (\f$K\f$) at height zlvl above ground +! th2 - air potential temperature (\f$K\f$) at height zlvl above ground +! q2 - mixing ratio at height zlvl above ground (\f$kg kg^{-1}\f$) + + lwdn = dlwflx(i) !..downward lw flux at sfc in w/m2 + swdn = dswsfc(i) !..downward sw flux at sfc in w/m2 + solnet = snet(i) !..net sw rad flx (dn-up) at sfc in w/m2 + sfcems = sfcemis(i) + + sfcprs = prsl1(i) + prcp = rhoh2o * tprcp(i) / delt + sfctmp = t1(i) + th2 = theta1(i) + q2 = q0(i) + +!> - 3. other forcing (input) data (i): +! sfcspd - wind speed (\f$m s^{-1}\f$) at height zlvl above ground +! q2sat - sat mixing ratio at height zlvl above ground (\f$kg kg^{-1}\f$) +! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (\f$kg kg^{-1} k^{-1}\f$) + + sfcspd = wind(i) + q2sat = qs1(i) + dqsdt2 = q2sat * a23m4/(sfctmp-a4)**2 + +!> - 4. canopy/soil characteristics (s): +! vegtyp - vegetation type (integer index) -> vtype +! soiltyp - soil type (integer index) -> stype +! slopetyp- class of sfc slope (integer index) -> slope +! shdfac - areal fractional coverage of green vegetation (0.0-1.0) +! shdmin - minimum areal fractional coverage of green vegetation -> shdmin1d +! ptu - photo thermal unit (plant phenology for annuals/crops) +! alb - backround snow-free surface albedo (fraction) +! snoalb - upper bound on maximum albedo over deep snow -> snoalb1d +! tbot - bottom soil temperature (local yearly-mean sfc air temp) + + vtype = vegtype(i) + stype = soiltyp(i) + slope = slopetyp(i) + shdfac= sigmaf(i) + +!> - Call surface_perturbation::ppfbet() to perturb vegetation fraction that goes into gsflx(). +! perturb vegetation fraction that goes into sflx, use the same +! perturbation strategy as for albedo (percentile matching) +!! Following Gehne et al. (2018) \cite gehne_et_al_2018, a perturbation of vegetation +!! fraction is added to account for the uncertainty. A percentile matching technique +!! is applied to guarantee the perturbed vegetation fraction is bounded between 0 and +!! 1. The standard deviation of the perturbations is 0.25 for vegetation fraction of +!! 0.5 and the perturbations go to zero as vegetation fraction approaches its upper +!! or lower bound. + vegfp = vegfpert(i) ! sfc-perts, mgehne + if (pertvegf>zero) then + ! compute beta distribution parameters for vegetation fraction + mv = shdfac + sv = pertvegf*mv*(one-mv) + alphav = mv*mv*(one-mv)/(sv*sv)-mv + betav = alphav*(one-mv)/mv + ! compute beta distribution value corresponding + ! to the given percentile albPpert to use as new albedo + call ppfbet(vegfp,alphav,betav,iflag,vegftmp) + shdfac = vegftmp + endif +! *** sfc-perts, mgehne + + shdmin1d = shdmin(i) + shdmax1d = shdmax(i) + snoalb1d = snoalb(i) + + ptu = zero + alb = sfalb(i) + tbot = tg3(i) + +!> - 5. history (state) variables (h): +! cmc - canopy moisture content (\f$m\f$) +! t1 - ground/canopy/snowpack effective skin temperature (\f$K\f$) -> tsea +! stc(nsoil) - soil temp (\f$K\f$) -> stsoil +! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil +! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil +! snowh - actual snow depth (\f$m\f$) +! sneqv - liquid water-equivalent snow depth (\f$m\f$) +! albedo - surface albedo including snow effect (unitless fraction) +! ch - surface exchange coefficient for heat and moisture (\f$m s^{-1}\f$) -> chx +! cm - surface exchange coefficient for momentum (\f$m s^{-1}\f$) -> cmx +! z0 - surface roughness (\f$m\f$) -> zorl(\f$cm\f$) + + cmc = canopy(i) * 0.001_kind_phys ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter + + do k = 1, km + stsoil(k) = stc(i,k) + smsoil(k) = smc(i,k) + slsoil(k) = slc(i,k) + enddo + + snowh = snwdph(i) * 0.001_kind_phys ! convert from mm to m + sneqv = weasd(i) * 0.001_kind_phys ! convert from mm to m + if (sneqv /= zero .and. snowh == zero) then + snowh = 10.0_kind_phys * sneqv + endif + + chx = ch(i) * wind(i) ! compute conductance + cmx = cm(i) * wind(i) + chh(i) = chx * rho(i) + cmm(i) = cmx + +! ---- ... outside sflx, roughness uses cm as unit + z0 = zorl(i) * 0.01_kind_phys +! ---- mgehne, sfc-perts +! - Apply perturbation of soil type b parameter and leave area index. + bexpp = bexppert(i) ! sfc perts, mgehne + xlaip = xlaipert(i) ! sfc perts, mgehne + + if (lprnt .and. i == ipr) write(0,*)' ch=',ch(i),' cm=',cm(i), & + &' wind=',wind(i),' rho=',rho(i),' z0=',z0,' swdn=',swdn, & + &' solnet=',solnet,' lwdn=',lwdn,' sfcems=',sfcems,' sfctmp=', & + &sfctmp,' prcp=',prcp,' th2=',th2,' q2=',q2,' iveegsrc=',ivegsrc, & + &'vtype=',vtype,' stype=',stype + + +!> - Call Noah LSM gfssflx(). + + call gfssflx & ! ccppdox: these is sflx in mpbl +! --- inputs: + & ( nsoil, couple, ice, ffrozp, delt, zlvl, sldpth, & + & swdn, solnet, lwdn, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & + & vtype, stype, slope, shdmin1d, alb, snoalb1d, & + & bexpp, xlaip, & ! sfc-perts, mgehne + & lheatstrg, & +! --- input/outputs: + & tbot, cmc, tsea, stsoil, smsoil, slsoil, sneqv, chx, cmx, & + & z0, & +! --- outputs: + & nroot, shdfac, snowh, albedo, eta, sheat, ec, & + & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & + & flx1, flx2, flx3, runoff1, runoff2, runoff3, & + & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + +!> - Noah LSM: prepare variables for return to parent model and unit conversion. +!> - 6. output (o): +!!\n eta - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) +!!\n sheat - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) +!!\n beta - ratio of actual/potential evap (dimensionless) +!!\n etp - potential evaporation (\f$W m^{-2}\f$) +!!\n ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) +!!\n runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface +!!\n runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom + + evap(i) = eta + hflx(i) = sheat + gflux(i) = ssoil + + evbs(i) = edir + evcw(i) = ec + trans(i) = ett + sbsno(i) = esnow + snowc(i) = sncovr + stm(i) = soilm * 1000.0_kind_phys ! unit conversion (from m to kg m-2) + snohf(i) = flx1 + flx2 + flx3 + + smcwlt2(i) = smcwlt + smcref2(i) = smcref + + ep(i) = etp + tsurf(i) = tsea + + do k = 1, km + stc(i,k) = stsoil(k) + smc(i,k) = smsoil(k) + slc(i,k) = slsoil(k) + enddo + wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) + +! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) + runoff(i) = runoff1 * 1000.0_kind_phys + drain (i) = runoff2 * 1000.0_kind_phys + +! --- ... unit conversion (from m to mm) + canopy(i) = cmc * 1000.0_kind_phys + snwdph(i) = snowh * 1000.0_kind_phys + weasd(i) = sneqv * 1000.0_kind_phys + sncovr1(i) = sncovr +! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) + zorl(i) = z0*100.0_kind_phys + +!> - Do not return the following output fields to parent model: +!!\n ec - canopy water evaporation (m s-1) +!!\n edir - direct soil evaporation (m s-1) +!!\n et(nsoil)-plant transpiration from a particular root layer (m s-1) +!!\n ett - total plant transpiration (m s-1) +!!\n esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +!!\n drip - through-fall of precip and/or dew in excess of canopy +!! water-holding capacity (m) +!!\n dew - dewfall (or frostfall for t<273.15) (m) +!!\n beta - ratio of actual/potential evap (dimensionless) +!!\n flx1 - precip-snow sfc (w m-2) +!!\n flx2 - freezing rain latent heat flux (w m-2) +!!\n flx3 - phase-change heat flux from snowmelt (w m-2) +!!\n snomlt - snow melt (m) (water equivalent) +!!\n sncovr - fractional snow cover (unitless fraction, 0-1) +!!\n runoff3 - numerical trunctation in excess of porosity (smcmax) +!! for a given soil layer at the end of a time step +!!\n rc - canopy resistance (s m-1) +!!\n pc - plant coefficient (unitless fraction, 0-1) where pc*etp +!! = actual transp +!!\n xlai - leaf area index (dimensionless) +!!\n rsmin - minimum canopy resistance (s m-1) +!!\n rcs - incoming solar rc factor (dimensionless) +!!\n rct - air temperature rc factor (dimensionless) +!!\n rcq - atmos vapor pressure deficit rc factor (dimensionless) +!!\n rcsoil - soil moisture rc factor (dimensionless) +!!\n soilw - available soil moisture in root zone (unitless fraction +!! between smcwlt and smcmax) +!!\n soilm - total soil column moisture content (frozen+unfrozen) (m) +!!\n smcwlt - wilting point (volumetric) +!!\n smcdry - dry soil moisture threshold where direct evap frm top +!! layer ends (volumetric) +!!\n smcref - soil moisture threshold where transpiration begins to +!! stress (volumetric) +!!\n smcmax - porosity, i.e. saturated value of soil moisture +!! (volumetric) +!!\n nroot - number of root layers, a function of veg type, determined +!! in subroutine redprm. + +! endif ! end if flag_iter and flag +! enddo ! end do_i_loop + +!> - Compute specific humidity at surface (\a qsurf). + + rch(i) = rho(i) * cp * ch(i) * wind(i) + qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) + +!> - Compute surface upward sensible heat flux (\a hflx) and evaporation +!! flux (\a evap). + tem = one / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + + endif ! flag_iter & land + enddo + + if (lprnt) then + write(0,*)' in noah hflx=',hflx(ipr),' evap=',evap(ipr) + write(0,*)' tsurf=',tsurf(ipr),' tskin_old=',tskin_old(ipr) + endif + +!> - Restore land-related prognostic fields for guess run. + + do i = 1, im + if (land(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_old(i) + snwdph(i) = snwdph_old(i) + tskin(i) = tskin_old(i) + canopy(i) = canopy_old(i) + tprcp(i) = tprcp_old(i) + srflag(i) = srflag_old(i) + + do k = 1, km + smc(i,k) = smc_old(i,k) + stc(i,k) = stc_old(i,k) + slc(i,k) = slc_old(i,k) + enddo + else ! flag_guess = F + tskin(i) = tsurf(i) + endif ! flag_guess + endif ! land + enddo +! + return +!................................... + end subroutine lsm_noah_run +!----------------------------- +!> @} + + end module lsm_noah diff --git a/physics/debug/sfc_drv.meta_dbg b/physics/debug/sfc_drv.meta_dbg new file mode 100644 index 000000000..7b400d762 --- /dev/null +++ b/physics/debug/sfc_drv.meta_dbg @@ -0,0 +1,788 @@ +[ccpp-table-properties] + name = lsm_noah + type = scheme + dependencies = funcphys.f90,machine.F,set_soilveg.f,sflx.f,surface_perturbation.F90 + +######################################################################## +[ccpp-arg-table] + name = lsm_noah_init + type = scheme +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[nlunit] + standard_name = iounit_namelist + long_name = fortran unit number for file opens + units = none + dimensions = () + type = integer + intent = in + optional = F +[pores] + standard_name = maximum_soil_moisture_content_for_land_surface_model + long_name = maximum soil moisture for a given soil type for land surface model + units = m + dimensions = (30) + type = real + intent = out + kind = kind_phys +[resid] + standard_name = minimum_soil_moisture_content_for_land_surface_model + long_name = minimum soil moisture for a given soil type for land surface model + units = m + dimensions = (30) + type = real + intent = out + kind = kind_phys +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = lsm_noah_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = lsm_noah_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = soil_vertical_dimension + long_name = soil vertical layer dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = 1st model layer air temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = 1st model layer specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[soiltyp] + standard_name = soil_type_classification + long_name = soil type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfcemis] + standard_name = surface_longwave_emissivity_over_land_interstitial + long_name = surface lw emissivity in fraction over land (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dlwflx] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land + long_name = total sky surface downward longwave flux absorbed by the ground over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = total sky surface downward shortwave flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snet] + standard_name = surface_net_downwelling_shortwave_flux + long_name = total sky surface net shortwave flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = bottom soil temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_land + long_name = surface exchange coeff for momentum over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land + long_name = surface exchange coeff heat & moisture over land + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = Model layer 1 mean pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = height above ground at 1st model layer + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[land] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[slopetyp] + standard_name = surface_slope_classification + long_name = surface slope type at each grid cell + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[shdmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green veg + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractnl cover of green veg (not used) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = upper bound on max albedo over deep snow + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfalb] + standard_name = surface_diffused_shortwave_albedo + long_name = mean surface diffused shortwave albedo + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[isot] + standard_name = soil_type_dataset_choice + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = vegetation_type_dataset_choice + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[bexppert] + standard_name = perturbation_of_soil_type_b_parameter + long_name = perturbation of soil type "b" parameter + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[xlaipert] + standard_name = perturbation_of_leaf_area_index + long_name = perturbation of leaf area index + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[vegfpert] + standard_name = perturbation_of_vegetation_fraction + long_name = perturbation of vegetation fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[pertvegf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_land + long_name = water equiv of acc snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_land + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin] + standard_name = surface_skin_temperature_over_land_interstitial + long_name = surface skin temperature over land (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land + long_name = total precipitation amount in each time step over land + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = flag for snow or rain precipitation + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = volumetric fraction of soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = volume fraction of unfrozen soil moisture + units = frac + dimensions = (horizontal_loop_extent,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy moisture content + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[trans] + standard_name = transpiration_flux + long_name = total plant transpiration rate + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tsurf] + standard_name = surface_skin_temperature_after_iteration_over_land + long_name = surface skin temperature after iteration over land + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorl] + standard_name = surface_roughness_length_over_land_interstitial + long_name = surface roughness length over land (temporary use as interstitial) + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sncovr1] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sbsno] + standard_name = snow_deposition_sublimation_upward_latent_heat_flux + long_name = latent heat flux from snow depo/subl + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[stm] + standard_name = soil_moisture_content + long_name = soil moisture content + units = kg m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snohf] + standard_name = snow_freezing_rain_upward_latent_heat_flux + long_name = latent heat flux due to snow and frz rain + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = soil water fraction at wilting point + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[smcref2] + standard_name = threshold_volume_fraction_of_condensed_water_in_soil + long_name = soil moisture threshold + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[wet1] + standard_name = normalized_soil_wetness + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 680e32bac7e2821a5df2b1ad2bf48b03e4ad30b0 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 2 Apr 2021 14:58:19 -0400 Subject: [PATCH 038/165] remove a duplicate line in GFS_surface_composites.F90 --- physics/GFS_surface_composites.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 074e5bc4b..d9087b0d4 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -613,7 +613,6 @@ subroutine GFS_surface_composites_post_run ( tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) - qss(i) = qss_ice(i) tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) ! From 55868e4f31f45ac9fc205e203ab4b656427295d5 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 14 Apr 2021 05:15:21 +0000 Subject: [PATCH 039/165] Prevent SAMF aerosol convective transport scheme from using uninitialized elements of cloud base mass flux array. --- physics/samfaerosols.F | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/samfaerosols.F b/physics/samfaerosols.F index 9d7f91e99..87a2277dd 100644 --- a/physics/samfaerosols.F +++ b/physics/samfaerosols.F @@ -92,7 +92,7 @@ subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, do k = 1, km do i = 1, im - xmbp(i,k) = g * xmb(i) / delp(i,k) + if (cnvflg(i)) xmbp(i,k) = g * xmb(i) / delp(i,k) enddo enddo @@ -493,7 +493,7 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, do k = 1, km do i = 1, im - xmbp(i,k) = g * xmb(i) / delp(i,k) + if (cnvflg(i)) xmbp(i,k) = g * xmb(i) / delp(i,k) enddo enddo From 9393e61b7b00959bcc1b3242374f94c7d5029d4f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 27 Apr 2021 21:10:38 -0400 Subject: [PATCH 040/165] updating sfcsub for fractional grid and a fix in sfc_sice --- physics/GFS_phys_time_vary.fv3.F90 | 6 +- physics/GFS_phys_time_vary.fv3.meta | 9 + physics/debug/GFS_surface_composites.F90_dbg | 111 +- physics/debug/GFS_surface_composites.meta_dbg | 287 +- physics/debug/gcycle.F90_dbg | 257 + physics/debug/sfc_sice.f_dbg | 772 ++ physics/debug/sfc_sice.meta_dbg | 478 + physics/debug/sfcsub.F_dbg | 8772 +++++++++++++++++ physics/gcycle.F90 | 124 +- physics/sfc_sice.f | 13 +- physics/sfc_sice.meta | 8 + physics/sfcsub.F | 451 +- 12 files changed, 10790 insertions(+), 498 deletions(-) create mode 100644 physics/debug/gcycle.F90_dbg create mode 100644 physics/debug/sfc_sice.f_dbg create mode 100644 physics/debug/sfc_sice.meta_dbg create mode 100644 physics/debug/sfcsub.F_dbg diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 0f53edc35..b4341fb5a 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -705,7 +705,7 @@ subroutine GFS_phys_time_vary_timestep_init ( lakefrac, min_seaice, min_lakeice, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, & tsfc, tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, zorli, zorll, & zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, stype, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, landfrac, & do_ugwp_v1, jindx1_tau, jindx2_tau, ddy_j1tau, ddy_j2tau, tau_amf, errmsg, errflg) implicit none @@ -742,7 +742,7 @@ subroutine GFS_phys_time_vary_timestep_init ( character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid real(kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), min_seaice, min_lakeice, & - xlat_d(:), xlon_d(:) + xlat_d(:), xlon_d(:), landfrac(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & tslb(:,:), tiice(:,:), tg3(:), tref(:), & tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & @@ -881,7 +881,7 @@ subroutine GFS_phys_time_vary_timestep_init ( if (mod(kdt,nscyc) == 1) THEN call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 373e36846..b42347421 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1954,6 +1954,15 @@ kind = kind_phys intent = inout optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [slmsk] standard_name = sea_land_ice_mask_real long_name = landmask: sea/land/ice=0/1/2 diff --git a/physics/debug/GFS_surface_composites.F90_dbg b/physics/debug/GFS_surface_composites.F90_dbg index e9eb86473..cef075a1f 100644 --- a/physics/debug/GFS_surface_composites.F90_dbg +++ b/physics/debug/GFS_surface_composites.F90_dbg @@ -13,6 +13,8 @@ module GFS_surface_composites_pre real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys + real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue + contains subroutine GFS_surface_composites_pre_init () @@ -25,16 +27,16 @@ contains !! \htmlinclude GFS_surface_composites_pre_run.html !! subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, ocean, wet, hice, cice, zorl, zorlo, zorll, zorli, zorl_wat, & - zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, dry, icy, use_flake, ocean, wet, & + hice, cice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & + min_lakeice, min_seaice, zorlo, zorll, zorli, & xlon, xlat, lprnt, ipr, kdt, & - min_lakeice, min_seaice, errmsg, errflg) + errmsg, errflg) implicit none @@ -44,17 +46,17 @@ contains logical, intent(in ) :: frac_grid, cplflx, cplwav2atm logical, intent(inout) :: lprnt logical, dimension(im), intent(inout) :: flag_cice - logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet + logical, dimension(im), intent(inout) :: dry, icy, use_flake, ocean, wet real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(im), intent(inout) :: cice, hice real(kind=kind_phys), dimension(im), intent( out) :: frland - real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd, qss, hflx + real(kind=kind_phys), dimension(im), intent(in ) :: snowd, tprcp, uustar, weasd, qss, hflx real(kind=kind_phys), dimension(im), intent(in ) :: xlon, xlat - real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli, tsfc, tsfco, tsfcl, tisfc, tsurf + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, tsfco, tsfcl, tisfc, tsurf real(kind=kind_phys), dimension(im), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & - tprcp_lnd, tprcp_ice, zorl_wat, zorl_lnd, zorl_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat, & - tsurf_lnd, tsurf_ice, uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & + tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice @@ -62,7 +64,9 @@ contains real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice - + ! + real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli + ! real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice real(kind=kind_phys), parameter :: degrad = 180.0/3.1415926 @@ -80,11 +84,8 @@ contains lprnt = .false. do i=1,im -! lprnt = kdt > 16052 .and. abs(xlon(i)*degrad-106.9) < 0.1 & -! lprnt = kdt > 16020 .and. abs(xlon(i)*degrad-106.9) < 0.1 & -! .and. abs(xlat(i)*degrad+32.00) < 0.1 - lprnt = kdt > 285 .and. kdt < 291 .and. abs(xlon(i)*degrad-70.5) < 0.1 & - .and. abs(xlat(i)*degrad-39.23) < 0.1 + lprnt = kdt > 0 .and. kdt < 25 .and. abs(xlon(i)*degrad-109.01) < 0.1 & + .and. abs(xlat(i)*degrad+66.35) < 0.1 if (lprnt) then ipr = i write(0,*)' lprnt=',lprnt,' ipr=',ipr,' xlon_d=',xlon(i)*degrad,' xlat_d=',xlat(i)*degrad @@ -200,28 +201,12 @@ contains enddo endif - if (lprnt) write(0,*)' tisfc1=',tisfc(ipr),' kdt=',kdt - -! if (.not. cplflx .or. .not. frac_grid) then -! if (cplwav2atm) then -! do i=1,im -! zorll(i) = zorl(i) -! enddo -! else -! do i=1,im -! zorll(i) = zorl(i) -! zorlo(i) = zorl(i) -! enddo -! endif -! endif - do i=1,im tprcp_wat(i) = tprcp(i) tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water ! uustar_wat(i) = uustar(i) - zorl_wat(i) = zorlo(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) ! weasd_wat(i) = weasd(i) @@ -232,22 +217,28 @@ contains ! semis_wat(i) = 0.984_kind_phys ! qss_wat(i) = qss(i) ! hflx_wat(i) = hflx(i) + ! DH* + else + zorlo(i) = huge + ! *DH endif if (dry(i)) then ! Land uustar_lnd(i) = uustar(i) weasd_lnd(i) = weasd(i) - zorl_lnd(i) = zorll(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) ! snowd_lnd(i) = snowd(i) / frland(i) semis_lnd(i) = semis_rad(i) ! qss_lnd(i) = qss(i) ! hflx_lnd(i) = hflx(i) - end if + ! DH* + else + zorll(i) = huge + ! *DH + endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) - zorl_ice(i) = zorli(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) ! snowd_ice(i) = snowd(i) / cice(i) @@ -257,20 +248,24 @@ contains ! semis_ice(i) = 0.95_kind_phys ! qss_ice(i) = qss(i) ! hflx_ice(i) = hflx(i) + ! DH* + else + zorli(i) = huge + ! *DH endif if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) enddo ! to prepare to separate lake from ocean under water category do i = 1, im - if(lkm == 1) then + if(wet(i) .and. lkm == 1) then if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - lake(i) = .true. + use_flake(i) = .true. else - lake(i) = .false. + use_flake(i) = .false. endif else - lake(i) = .false. + use_flake(i) = .false. endif enddo ! @@ -306,8 +301,6 @@ contains tice(i) = tisfc(i) enddo - if (lprnt) write(0,*)' tisfc2=',tisfc(ipr),' tice=',tice(ipr),' kdt=',kdt - end subroutine GFS_surface_composites_pre_run end module GFS_surface_composites_pre @@ -409,14 +402,12 @@ contains subroutine GFS_surface_composites_post_finalize() end subroutine GFS_surface_composites_post_finalize -#if 0 !> \section arg_table_GFS_surface_composites_post_run Argument Table !! \htmlinclude GFS_surface_composites_post_run.html !! -#endif subroutine GFS_surface_composites_post_run ( & im, kice, km, cplflx, cplwav2atm, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & - zorl, zorlo, zorll, zorli, zorl_wat, zorl_lnd, zorl_ice, & + zorl, zorlo, zorll, zorli, & cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & @@ -432,7 +423,7 @@ contains logical, dimension(im), intent(in) :: flag_cice, dry, wet, icy integer, dimension(im), intent(in) :: islmsk real(kind=kind_phys), dimension(im), intent(in) :: landfrac, lakefrac, oceanfrac, & - zorl_wat, zorl_lnd, zorl_ice, cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & + cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & @@ -474,7 +465,9 @@ contains txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell txo = max(zero, wfrac-txi) ! txo = open water fraction - zorl(i) = txl*zorl_lnd(i) + txi*zorl_ice(i) + txo*zorl_wat(i) + zorl(i) = txl*zorll(i) + txi*zorli(i) + txo*zorlo(i) +! zorl(i) = txl*log(zorll(i)) + txi*log(zorli(i)) + txo*log(zorlo(i)) +! zorl(i) = exp(zorl(i)) cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) cdq(i) = txl*cdq_lnd(i) + txi*cdq_ice(i) + txo*cdq_wat(i) rb(i) = txl*rb_lnd(i) + txi*rb_ice(i) + txo*rb_wat(i) @@ -509,10 +502,6 @@ contains endif tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_wat(i) - zorll(i) = zorl_lnd(i) - zorli(i) = zorl_ice(i) - zorlo(i) = zorl_wat(i) - if (dry(i)) then tsfcl(i) = tsfc_lnd(i) ! over land elseif (wet(i)) then @@ -562,7 +551,7 @@ contains do i=1,im if (islmsk(i) == 1) then - zorl(i) = zorl_lnd(i) + zorl(i) = zorll(i) cd(i) = cd_lnd(i) cdq(i) = cdq_lnd(i) rb(i) = rb_lnd(i) @@ -589,7 +578,7 @@ contains hice(i) = zero cice(i) = zero elseif (islmsk(i) == 0) then - zorl(i) = zorl_wat(i) + zorl(i) = zorlo(i) cd(i) = cd_wat(i) cdq(i) = cdq_wat(i) rb(i) = rb_wat(i) @@ -616,7 +605,7 @@ contains hice(i) = zero cice(i) = zero else ! islmsk(i) == 2 - zorl(i) = zorl_ice(i) + zorl(i) = zorli(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) rb(i) = rb_ice(i) @@ -637,7 +626,6 @@ contains tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) - qss(i) = qss_ice(i) tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) ! @@ -651,11 +639,15 @@ contains stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) + zorl(i) = txi * zorli(i) + txo * zorlo(i) +! zorl(i) = txi * log(zorli(i)) + txo * log(zorlo(i)) +! zorl(i) = exp(zorl(i)) snowd(i) = txi * snowd_ice(i) endif elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = cice(i)*zorl_ice(i) + (one-cice(i))*zorl_wat(i) + zorl(i) = cice(i)*zorli(i) + (one-cice(i))*zorlo(i) +! zorl(i) = cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i)) +! zorl(i) = exp(zorl(i)) endif ! if (wet(i)) then @@ -669,16 +661,13 @@ contains enddo endif - zorll(i) = zorl_lnd(i) - zorlo(i) = zorl_wat(i) - zorli(i) = zorl_ice(i) - enddo if (lprnt) write(0,*)' tisfc=',tisfc(ipr),' tice=',tice(ipr),' kdt=',kdt if (lprnt) write(0,*)' tsfc=',tsfc(ipr),' tice=',tice(ipr),' kdt=',kdt - if (lprnt) write(0,*)' hflx=',hflx(ipr),' evap=',evap(ipr),' cice=',cice(ipr),' kdt=',kdt,& - ' hflx_wat=',hflx_wat(ipr),' wet=',wet(ipr),' evap_wat=',evap_wat(ipr) +! if (lprnt) write(0,*)' hflx=',hflx(ipr),' evap=',evap(ipr),' cice=',cice(ipr),' kdt=',kdt,& +! ' hflx_wat=',hflx_wat(ipr),' wet=',wet(ipr),' evap_wat=',evap_wat(ipr) + if (lprnt) write(0,*)' tiice_comp=',tiice(ipr,:) endif ! if (frac_grid) diff --git a/physics/debug/GFS_surface_composites.meta_dbg b/physics/debug/GFS_surface_composites.meta_dbg index 595841fd7..a68dcb2c0 100644 --- a/physics/debug/GFS_surface_composites.meta_dbg +++ b/physics/debug/GFS_surface_composites.meta_dbg @@ -116,7 +116,7 @@ type = logical intent = inout optional = F -[lake] +[use_flake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag @@ -158,69 +158,6 @@ kind = kind_phys intent = inout optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zorlo] - standard_name = surface_roughness_length_over_ocean - long_name = surface roughness length over ocean - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorll] - standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorl_wat] - standard_name = surface_roughness_length_over_ocean_interstitial - long_name = surface roughness length over ocean (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorl_lnd] - standard_name = surface_roughness_length_over_land_interstitial - long_name = surface roughness length over land (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorl_ice] - standard_name = surface_roughness_length_over_ice_interstitial - long_name = surface roughness length over ice (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [snowd] standard_name = surface_snow_thickness_water_equivalent long_name = water equivalent snow depth @@ -231,8 +168,8 @@ intent = in optional = F [snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_ocean - long_name = water equivalent snow depth over ocean + standard_name = surface_snow_thickness_water_equivalent_over_water + long_name = water equivalent snow depth over water units = mm dimensions = (horizontal_loop_extent) type = real @@ -267,8 +204,8 @@ intent = in optional = F [tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean - long_name = total precipitation amount in each time step over ocean + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water + long_name = total precipitation amount in each time step over water units = m dimensions = (horizontal_loop_extent) type = real @@ -303,8 +240,8 @@ intent = in optional = F [uustar_wat] - standard_name = surface_friction_velocity_over_ocean - long_name = surface friction velocity over ocean + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water units = m s-1 dimensions = (horizontal_loop_extent) type = real @@ -339,8 +276,8 @@ intent = in optional = F [weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_ocean - long_name = water equiv of acc snow depth over ocean + standard_name = water_equivalent_accumulated_snow_depth_over_water + long_name = water equiv of acc snow depth over water units = mm dimensions = (horizontal_loop_extent) type = real @@ -402,8 +339,8 @@ intent = inout optional = F [tsfc_wat] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) + standard_name = surface_skin_temperature_over_water_interstitial + long_name = surface skin temperature over water (temporary use as interstitial) units = K dimensions = (horizontal_loop_extent) type = real @@ -456,8 +393,8 @@ intent = inout optional = F [tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_ocean - long_name = surface skin temperature after iteration over ocean + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water units = K dimensions = (horizontal_loop_extent) type = real @@ -535,8 +472,8 @@ intent = in optional = F [semis_wat] - standard_name = surface_longwave_emissivity_over_ocean_interstitial - long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_water_interstitial + long_name = surface lw emissivity in fraction over water (temporary use as interstitial) units = frac dimensions = (horizontal_loop_extent) type = real @@ -571,8 +508,8 @@ intent = in optional = F [qss_wat] - standard_name = surface_specific_humidity_over_ocean - long_name = surface air saturation specific humidity over ocean + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water units = kg kg-1 dimensions = (horizontal_loop_extent) type = real @@ -607,8 +544,8 @@ intent = in optional = F [hflx_wat] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_ocean - long_name = kinematic surface upward sensible heat flux over ocean + standard_name = kinematic_surface_upward_sensible_heat_flux_over_water + long_name = kinematic surface upward sensible heat flux over water units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -633,6 +570,51 @@ kind = kind_phys intent = inout optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[zorlo] + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorll] + standard_name = surface_roughness_length_over_land + long_name = surface roughness length over land + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [xlon] standard_name = longitude long_name = longitude @@ -675,24 +657,6 @@ type = integer intent = in optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -754,8 +718,8 @@ intent = in optional = F [semis_wat] - standard_name = surface_longwave_emissivity_over_ocean_interstitial - long_name = surface lw emissivity in fraction over ocean (temporary use as interstitial) + standard_name = surface_longwave_emissivity_over_water_interstitial + long_name = surface lw emissivity in fraction over water (temporary use as interstitial) units = frac dimensions = (horizontal_loop_extent) type = real @@ -808,8 +772,8 @@ intent = inout optional = F [gabsbdlw_wat] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ocean - long_name = total sky surface downward longwave flux absorbed by the ground over ocean + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water + long_name = total sky surface downward longwave flux absorbed by the ground over water units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -996,8 +960,8 @@ intent = inout optional = F [zorlo] - standard_name = surface_roughness_length_over_ocean - long_name = surface roughness length over ocean + standard_name = surface_roughness_length_over_water + long_name = surface roughness length over water units = cm dimensions = (horizontal_loop_extent) type = real @@ -1022,33 +986,6 @@ kind = kind_phys intent = inout optional = F -[zorl_wat] - standard_name = surface_roughness_length_over_ocean_interstitial - long_name = surface roughness length over ocean (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zorl_lnd] - standard_name = surface_roughness_length_over_land_interstitial - long_name = surface roughness length over land (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zorl_ice] - standard_name = surface_roughness_length_over_ice_interstitial - long_name = surface roughness length over ice (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [cd] standard_name = surface_drag_coefficient_for_momentum_in_air long_name = surface exchange coeff for momentum @@ -1059,8 +996,8 @@ intent = inout optional = F [cd_wat] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean - long_name = surface exchange coeff for momentum over ocean + standard_name = surface_drag_coefficient_for_momentum_in_air_over_water + long_name = surface exchange coeff for momentum over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1095,8 +1032,8 @@ intent = inout optional = F [cdq_wat] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean - long_name = surface exchange coeff heat & moisture over ocean + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water + long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1131,8 +1068,8 @@ intent = inout optional = F [rb_wat] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean - long_name = bulk Richardson number at the surface over ocean + standard_name = bulk_richardson_number_at_lowest_model_level_over_water + long_name = bulk Richardson number at the surface over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1167,8 +1104,8 @@ intent = inout optional = F [stress_wat] - standard_name = surface_wind_stress_over_ocean - long_name = surface wind stress over ocean + standard_name = surface_wind_stress_over_water + long_name = surface wind stress over water units = m2 s-2 dimensions = (horizontal_loop_extent) type = real @@ -1203,8 +1140,8 @@ intent = inout optional = F [ffmm_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean - long_name = Monin-Obukhov similarity function for momentum over ocean + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water + long_name = Monin-Obukhov similarity function for momentum over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1239,8 +1176,8 @@ intent = inout optional = F [ffhh_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean - long_name = Monin-Obukhov similarity function for heat over ocean + standard_name = Monin_Obukhov_similarity_function_for_heat_over_water + long_name = Monin-Obukhov similarity function for heat over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1275,8 +1212,8 @@ intent = inout optional = F [uustar_wat] - standard_name = surface_friction_velocity_over_ocean - long_name = surface friction velocity over ocean + standard_name = surface_friction_velocity_over_water + long_name = surface friction velocity over water units = m s-1 dimensions = (horizontal_loop_extent) type = real @@ -1311,8 +1248,8 @@ intent = inout optional = F [fm10_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water + long_name = Monin-Obukhov similarity parameter for momentum at 10m over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1347,8 +1284,8 @@ intent = inout optional = F [fh2_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean - long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_water + long_name = Monin-Obukhov similarity parameter for heat at 2m over water units = none dimensions = (horizontal_loop_extent) type = real @@ -1383,8 +1320,8 @@ intent = inout optional = F [tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_ocean - long_name = surface skin temperature after iteration over ocean + standard_name = surface_skin_temperature_after_iteration_over_water + long_name = surface skin temperature after iteration over water units = K dimensions = (horizontal_loop_extent) type = real @@ -1419,8 +1356,8 @@ intent = inout optional = F [cmm_wat] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ocean - long_name = momentum exchange coefficient over ocean + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water + long_name = momentum exchange coefficient over water units = m s-1 dimensions = (horizontal_loop_extent) type = real @@ -1455,8 +1392,8 @@ intent = inout optional = F [chh_wat] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ocean - long_name = thermal exchange coefficient over ocean + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water + long_name = thermal exchange coefficient over water units = kg m-2 s-1 dimensions = (horizontal_loop_extent) type = real @@ -1491,8 +1428,8 @@ intent = inout optional = F [gflx_wat] - standard_name = upward_heat_flux_in_soil_over_ocean - long_name = soil heat flux over ocean + standard_name = upward_heat_flux_in_soil_over_water + long_name = soil heat flux over water units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -1527,8 +1464,8 @@ intent = inout optional = F [ep1d_wat] - standard_name = surface_upward_potential_latent_heat_flux_over_ocean - long_name = surface upward potential latent heat flux over ocean + standard_name = surface_upward_potential_latent_heat_flux_over_water + long_name = surface upward potential latent heat flux over water units = W m-2 dimensions = (horizontal_loop_extent) type = real @@ -1563,8 +1500,8 @@ intent = inout optional = F [weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_ocean - long_name = water equiv of acc snow depth over ocean + standard_name = water_equivalent_accumulated_snow_depth_over_water + long_name = water equiv of acc snow depth over water units = mm dimensions = (horizontal_loop_extent) type = real @@ -1599,8 +1536,8 @@ intent = inout optional = F [snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_ocean - long_name = water equivalent snow depth over ocean + standard_name = surface_snow_thickness_water_equivalent_over_water + long_name = water equivalent snow depth over water units = mm dimensions = (horizontal_loop_extent) type = real @@ -1635,8 +1572,8 @@ intent = inout optional = F [tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean - long_name = total precipitation amount in each time step over ocean + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water + long_name = total precipitation amount in each time step over water units = m dimensions = (horizontal_loop_extent) type = real @@ -1671,8 +1608,8 @@ intent = inout optional = F [evap_wat] - standard_name = kinematic_surface_upward_latent_heat_flux_over_ocean - long_name = kinematic surface upward latent heat flux over ocean + standard_name = kinematic_surface_upward_latent_heat_flux_over_water + long_name = kinematic surface upward latent heat flux over water units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real @@ -1707,8 +1644,8 @@ intent = inout optional = F [hflx_wat] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_ocean - long_name = kinematic surface upward sensible heat flux over ocean + standard_name = kinematic_surface_upward_sensible_heat_flux_over_water + long_name = kinematic surface upward sensible heat flux over water units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -1743,8 +1680,8 @@ intent = inout optional = F [qss_wat] - standard_name = surface_specific_humidity_over_ocean - long_name = surface air saturation specific humidity over ocean + standard_name = surface_specific_humidity_over_water + long_name = surface air saturation specific humidity over water units = kg kg-1 dimensions = (horizontal_loop_extent) type = real @@ -1797,8 +1734,8 @@ intent = inout optional = F [tsfc_wat] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) + standard_name = surface_skin_temperature_over_water_interstitial + long_name = surface skin temperature over water (temporary use as interstitial) units = K dimensions = (horizontal_loop_extent) type = real diff --git a/physics/debug/gcycle.F90_dbg b/physics/debug/gcycle.F90_dbg new file mode 100644 index 000000000..723580f65 --- /dev/null +++ b/physics/debug/gcycle.F90_dbg @@ -0,0 +1,257 @@ +!>\file gcycle.F90 +!! This file repopulates specific time-varying surface properties for +!! atmospheric forecast runs. + +module gcycle_mod + + implicit none + + private + + public gcycle + +contains + +!>\ingroup mod_GFS_phys_time_vary +!! This subroutine repopulates specific time-varying surface properties for +!! atmospheric forecast runs. + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + xlat_d, xlon_d, slmsk, imap, jmap) +! +! + use machine, only: kind_phys, kind_io8 + implicit none + + integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & + tile_num, nlunit, lsoil, lsoil_lsm, kice + integer, intent(in) :: idate(:), ialb, isot, ivegsrc + character(len=*), intent(in) :: input_nml_file(:) + logical, intent(in) :: use_ufo, nst_anl, frac_grid + real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & + min_seaice, min_lakeice, & + xlat_d(:), xlon_d(:) + real(kind=kind_phys), intent(inout) :: smc(:,:), & + slc(:,:), & + stc(:,:), & + smois(:,:), & + sh2o(:,:), & + tslb(:,:), & + tiice(:,:), & + tg3(:), & + tref(:), & + tsfc(:), & + tsfco(:), & + tisfc(:), & + hice(:), & + fice(:), & + facsf(:), & + facwf(:), & + alvsf(:), & + alvwf(:), & + alnsf(:), & + alnwf(:), & + zorli(:), & + zorll(:), & + zorlo(:), & + weasd(:), & + slope(:), & + snoalb(:), & + canopy(:), & + vfrac(:), & + vtype(:), & + stype(:), & + shdmin(:), & + shdmax(:), & + snowd(:), & + cv(:), & + cvb(:), & + cvt(:), & + oro(:), & + oro_uf(:), & + slmsk(:) + + integer, intent(in) :: imap(:), jmap(:) +! +! Local variables +! --------------- + real(kind=kind_phys) :: & +! SLMASK (nx*ny), & + slmskl (nx*ny), & + slmskw (nx*ny), & + TSFFCS (nx*ny), & + ZORFCS (nx*ny), & + AISFCS (nx*ny), & + ALFFC1 (nx*ny*2), & + ALBFC1 (nx*ny*4), & + SMCFC1 (nx*ny*max(lsoil,lsoil_lsm)), & + STCFC1 (nx*ny*max(lsoil,lsoil_lsm)), & + SLCFC1 (nx*ny*max(lsoil,lsoil_lsm)) + + + real (kind=kind_io8) :: min_ice(nx*ny) + character(len=6) :: tile_num_ch + real(kind=kind_phys) :: sig1t, dt_warm + integer :: npts, nb, ix, jx, ls, ios, ll + logical :: exists +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' +! *,lonsinpe(0,1) +! + tile_num_ch = " " + if (tile_num < 10) then + write(tile_num_ch, "(a4,i1)") "tile", tile_num + else + write(tile_num_ch, "(a4,i2)") "tile", tile_num + endif +! + sig1t = 0.0_kind_phys + npts = nx*ny +! + if ( nsst > 0 ) then + TSFFCS = tref + else + TSFFCS = tsfco + end if +! + do ix=1,npts + if (lakefrac(ix) > 0.0_kind_phys) then + min_ice(ix) = min_lakeice + else + min_ice(ix) = min_seaice + endif + ZORFCS(ix) = zorll (ix) + IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + if (frac_grid) then + slmskw(ix) = floor(landfrac(ix)) + endif + ELSE + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + ENDIF + if (nint(slmskl(ix)) == 1 .and. nint(slmskw(ix)) == 0) then + ZORFCS(ix) = zorlo (ix) + endif + IF (fice(ix) >= min_ice(ix)) THEN + AISFCS(ix) = 1.0_kind_phys + ELSE + AISFCS(ix) = 0.0_kind_phys + ENDIF +! + ALFFC1(ix ) = facsf(ix) + ALFFC1(ix + npts ) = facwf(ix) +! + ALBFC1(ix ) = alvsf(ix) + ALBFC1(ix + npts ) = alvwf(ix) + ALBFC1(ix + npts*2) = alnsf(ix) + ALBFC1(ix + npts*3) = alnwf(ix) +! + do ls = 1,max(lsoil,lsoil_lsm) + ll = ix + (ls-1)*npts + if (lsoil == lsoil_lsm) then + SMCFC1(ll) = smc(ix,ls) + STCFC1(ll) = stc(ix,ls) + SLCFC1(ll) = slc(ix,ls) + else + SMCFC1(ll) = smois(ix,ls) + STCFC1(ll) = tslb(ix,ls) + SLCFC1(ll) = sh2o(ix,ls) + endif + enddo + enddo +! +#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, max(lsoil,lsoil_lsm), sig1t, fhcyc, & + idate(4), idate(2), idate(3), idate(1), & + phour, xlat_d, xlon_d, slmskl, slmskw, & + oro, oro_uf, use_ufo, nst_anl, & + hice, fice, tisfc, snowd, slcfc1, & + shdmin, shdmax, slope, snoalb, tsffcs, & + weasd, zorfcs, albfc1, tg3, canopy, & + smcfc1, stcfc1, slmsk, aisfcs, & + vfrac, vtype, stype, alffc1, cv, & + cvb, cvt, me, nthrds, & + nlunit, size(input_nml_file), input_nml_file, & + min_ice, ialb, isot, ivegsrc, & + trim(tile_num_ch), imap, jmap) +#ifndef INTERNAL_FILE_NML + close (Model%nlunit) +#endif +! + if ( nsst > 0 ) then + tref = TSFFCS + else +! tsfc = TSFFCS + tsfco = TSFFCS + endif +! + do ix=1,npts + zorll(ix) = ZORFCS(ix) + if (.not. frac_grid) then + if (slmsk(ix) > 1.9_kind_phys) then + zorli(ix) = ZORFCS(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + zorlo(ix) = ZORFCS(ix) + endif + else + if (nint(slmskw(ix)) == 0) then + if (fice(ix) >= min_ice(ix)) then + zorli(ix) = ZORFCS(ix) + else + zorlo(ix) = ZORFCS(ix) + endif + endif + endif +! + facsf(ix) = ALFFC1(ix ) + facwf(ix) = ALFFC1(ix + npts ) +! + alvsf(ix) = ALBFC1(ix ) + alvwf(ix) = ALBFC1(ix + npts ) + alnsf(ix) = ALBFC1(ix + npts*2) + alnwf(ix) = ALBFC1(ix + npts*3) +! + do ls = 1,max(lsoil,lsoil_lsm) + ll = ix + (ls-1)*npts + if(lsoil == lsoil_lsm) then + smc(ix,ls) = SMCFC1(ll) + stc(ix,ls) = STCFC1(ll) + slc(ix,ls) = SLCFC1(ll) + else + smois(ix,ls) = SMCFC1(ll) + tslb(ix,ls) = STCFC1(ll) + sh2o(ix,ls) = SLCFC1(ll) + endif + if (ls <= kice) tiice(ix,ls) = STCFC1(ll) + + if (me == 517 .and. ll == 851) write(0,*)' tiice_gcyc=',tiice(ix,ls)& + &,' STCFC1=',STCFc1(ll),' ix=',ix,' ll=',ll + + enddo + enddo +! if (me == 517 .and. ll == 851) write(0,*)' tiic3_gcyc=',tiice(19,:) +! +! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour +! + RETURN + END + +end module gcycle_mod diff --git a/physics/debug/sfc_sice.f_dbg b/physics/debug/sfc_sice.f_dbg new file mode 100644 index 000000000..ccaa8d9d7 --- /dev/null +++ b/physics/debug/sfc_sice.f_dbg @@ -0,0 +1,772 @@ +!> \file sfc_sice.f +!! This file contains the GFS three level thermodynamic sea ice model. + +!> This module contains the CCPP-compliant GFS sea ice scheme. + module sfc_sice + + contains + + subroutine sfc_sice_init() + end subroutine sfc_sice_init +! + subroutine sfc_sice_finalize() + end subroutine sfc_sice_finalize + +!>\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 +!! \htmlinclude sfc_sice_run.html +!! +!> \section general_sice_run GFS Sea Ice Driver General Algorithm +!!The model has four prognostic variables: the snow layer thickness \f$h_s\f$, the ice layer thickness +!! \f$h_i\f$, the upper and lower ice layer temperatures located at the midpoints of the layers +!! \f$h_i/4\f$ and \f$3h_i/4\f$ below the ice surface, respectively \f$T_1\f$ and \f$T_2\f$. The temperature of +!! the bottom of the ice is fixed at \f$T_f\f$, the freezing temperature of seawater. The temperature of +!! the top of the ice or snow, \f$T_s\f$, is determined from the surface energy balance. +!! The model consists of a zero-heat-capacity snow layer overlying two equally thick sea ice layers (Figure 1). +!! The upper ice layer has a variable heat capacity to represent brine pockets. +!! \image html GFS_sice_wonton2000_fig1.png "Fig.1 Schematic representation of the three-layer model" width=5cm +!! The ice model main program ice3lay() performs two functions: +!! - \b Calculation \b of \b ice \b temperature +!!\n The surface temperature is determined from the diagnostic balance between +!! the upward conduction of heat through snow and/or ice and upward flux of heat +!! from the surface. +!! - \b Calculation \b of \b ice \b and \b snow \b changes +!!\n In addition to calculating ice temperature changes, the ice model must +!! also readjust the sizes of the snow and ice layers 1) to accommodate +!! mass fluxes at the upper and lower surfaces, 2) to convert snow below +!! the water line to ice, and 3) to equalize the thickness of the two +!! ice layers. +!> \section detailed_sice_run GFS Sea Ice Driver Detailed Algorithm +!> @{ + subroutine sfc_sice_run & + & ( im, kice, sbc, hvap, tgice, cp, eps, epsm1, rvrdm1, grav, & ! --- inputs: + & t0c, rd, ps, t1, q1, delt, & + & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & + & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & + & flag_iter, lprnt, ipr, me, & + & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: + & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & + & islmsk_cice, & +! & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & + & xlon_d, xlat_d, & + & errmsg, errflg + & ) + +! ===================================================================== ! +! description: ! +! ! +! usage: ! +! ! +! call sfc_sice ! +! inputs: ! +! ( im, kice, ps, t1, q1, delt, ! +! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! +! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! +! flag_iter, ! +! input/outputs: ! +! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! +! outputs: ! +! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! +! ! +! subprogram called: ice3lay. ! +! ! +!> program history log: +!!- 2005 -- xingren wu created from original progtm and added +!! two-layer ice model +!!- 200x -- sarah lu added flag_iter +!!- oct 2006 -- h. wei added cmm and chh to output +!!- 2007 -- x. wu modified for mom4 coupling (i.e. cpldice) +!! (not used anymore) +!!- 2007 -- s. moorthi micellaneous changes +!!- may 2009 -- y.-t. hou modified to include surface emissivity +!! effect on lw radiation. replaced the confusing +!! slrad with sfc net sw sfcnsw (dn-up). reformatted +!! the code and add program documentation block. +!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and +!! further optimized +!!- jan 2015 -- x. wu change "cimin = 0.15" for both +!! uncoupled and coupled case +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im, kice - integer, horiz dimension and num of ice layers 1 ! +! ps - real, surface pressure im ! +! t1 - real, surface layer mean temperature ( k ) im ! +! q1 - real, surface layer mean specific humidity im ! +! delt - real, time interval (second) 1 ! +! sfcemis - real, sfc lw emissivity ( fraction ) im ! +! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! +! sfcnsw - real, total sky sfc netsw flx into ground(w/m**2) im ! +! sfcdsw - real, total sky sfc downward sw flux ( w/m**2 ) im ! +! srflag - real, snow/rain fraction for precipitation im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, surface layer mean pressure im ! +! prslki - real, im ! +! prsik1 - real, im ! +! prslk1 - real, im ! +! islimsk - integer, sea/land/ice mask (=0/1/2) im ! +! wind - real, im ! +! flag_iter- logical, im ! +! ! +! input/outputs: ! +! hice - real, sea-ice thickness im ! +! fice - real, sea-ice concentration im ! +! tice - real, sea-ice surface temperature im ! +! weasd - real, water equivalent accumulated snow depth (mm)im ! +! tskin - real, ground surface skin temperature ( k ) im ! +! tprcp - real, total precipitation im ! +! tiice - real, temperature of ice internal (k) im,kice ! +! ep - real, potential evaporation im ! +! ! +! outputs: ! +! snwdph - real, water equivalent snow depth (mm) im ! +! qsurf - real, specific humidity at sfc im ! +! snowmt - real, snow melt (m) im ! +! gflux - real, soil heat flux (w/m**2) im ! +! cmm - real, surface exchange coeff for momentum (m/s) im ! +! chh - real, surface exchange coeff heat&moisture (m/s) im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ! +! ===================================================================== ! +! + use machine, only : kind_phys + use funcphys, only : fpvs +! + implicit none +! +! - Define constant parameters + integer, parameter :: kmi = 2 !< 2-layer of ice + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: himax = 8.0_kind_phys !< maximum ice thickness allowed + real(kind=kind_phys), parameter :: himin = 0.1_kind_phys !< minimum ice thickness required + real(kind=kind_phys), parameter :: hsmax = 2.0_kind_phys !< maximum snow depth allowed + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys !< minimum temperature allowed for snow/ice + real(kind=kind_phys), parameter :: albfw = 0.06_kind_phys !< albedo for lead + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys + +! --- inputs: + integer, intent(in) :: im, kice, ipr, me + logical, intent(in) :: lprnt + + real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & + & epsm1, grav, rvrdm1, t0c, rd + + real (kind=kind_phys), dimension(im), intent(in) :: ps, & + & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & + & prsl1, prslki, prsik1, prslk1, wind + &, xlon_d, xlat_d +! & prsl1, prslki, prsik1, prslk1, wind, oceanfrac + +! integer, dimension(im), intent(in) :: islimsk + integer, dimension(im), intent(in) :: islmsk_cice + real (kind=kind_phys), intent(in) :: delt +! real (kind=kind_phys), intent(in) :: delt, min_seaice, & +! & min_lakeice + + logical, dimension(im), intent(in) :: flag_iter + +! --- input/outputs: + real (kind=kind_phys), dimension(im), intent(inout) :: hice, & + & fice, tice, weasd, tskin, tprcp, ep + + real (kind=kind_phys), dimension(im,kice), intent(inout) :: tiice + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(inout) :: snwdph, & + & qsurf, snowmt, gflux, cmm, chh, evap, hflx + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals: + real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & + & sneti, hfd, hfi, & +! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & + & focn, snof, rch, rho, & + & snowd, theta1 + + real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) + &, hflxi, hflxw, q0, qs1, qssi, qssw + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw +! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + + integer :: i, k + + logical :: flag(im) +! +!===> ... begin here +! + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lprnt) write(0,*)' in sfc_sice tiice=',tiice(ipr,:) +! +!> - Set flag for sea-ice. + + do i = 1, im + flag(i) = (islmsk_cice(i) == 2) .and. flag_iter(i) +! if (flag_iter(i) .and. islmsk_cice(i) < 2) then +! hice(i) = zero +! fice(i) = zero +! endif + enddo + + do i = 1, im + if (flag(i)) then + if (srflag(i) > zero) then + ep(i) = ep(i)*(one-srflag(i)) + weasd(i) = weasd(i) + 1000.0_kind_phys*tprcp(i)*srflag(i) + tprcp(i) = tprcp(i)*(one-srflag(i)) + endif + endif + enddo +! --- ... update sea ice temperature + + do k = 1, kice + do i = 1, im + if (flag(i)) then + stsice(i,k) = tiice(i,k) + endif + enddo + enddo + if (lprnt) write(0,*)' stsice=',stsice(ipr,:),' flag=',flag(ipr) + +! --- ... initialize variables. all units are supposedly m.k.s. unless specifie +! psurf is in pascals, wind is wind speed, theta1 is adiabatic surface +! temp from level 1, rho is density, qs1 is sat. hum. at level1 and qss +! is sat. hum. at surface +! convert slrad to the civilized unit from langley minute-1 k-4 + + do i = 1, im + if (flag(i)) then +! if (oceanfrac(i) > zero) then +! cimin = min_seaice +! else +! cimin = min_lakeice +! endif +! psurf(i) = 1000.0 * ps(i) +! ps1(i) = 1000.0 * prsl1(i) + +! dlwflx has been given a negative sign for downward longwave +! sfcnsw is the net shortwave flux (direction: dn-up) + + q0 = max(q1(i), qmin) +! tsurf(i) = tskin(i) +#ifdef GSD_SURFACE_FLUXES_BUGFIX + theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer +#else + theta1(i) = t1(i) * prslki(i) +#endif + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) + qs1 = fpvs(t1(i)) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) + q0 = min(qs1, q0) + +! if (fice(i) < cimin) then +! print *,'warning: ice fraction is low:', fice(i) +! fice(i) = cimin +! tice(i) = tgice +! tskin(i)= tgice +! print *,'fix ice fraction: reset it to:', fice(i) +! endif + ffw(i) = one - fice(i) + + qssi = fpvs(tice(i)) + qssi = eps*qssi / (ps(i) + epsm1*qssi) + qssw = fpvs(tgice) + qssw = eps*qssw / (ps(i) + epsm1*qssw) + +!> - Convert snow depth in water equivalent from mm to m unit. + + snowd(i) = weasd(i) * 0.001_kind_phys +! flagsnw(i) = .false. + +! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and +! soil is allowed to interact with the atmosphere. +! we should eventually move to a linear combination of soil and +! snow under the condition of patchy snow. + +! --- ... rcp = rho cp ch v + + cmm(i) = cm(i) * wind(i) + chh(i) = rho(i) * ch(i) * wind(i) + rch(i) = chh(i) * cp + +!> - Calculate sensible and latent heat flux over open water & sea ice. + + evapi(i) = elocp * rch(i) * (qssi - q0) + evapw(i) = elocp * rch(i) * (qssw - q0) +! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + + snetw = sfcdsw(i) * (one - albfw) + snetw = min(3.0_kind_phys*sfcnsw(i) & + & / (one+2.0_kind_phys*ffw(i)), snetw) +!> - Calculate net solar incoming at top \a sneti. + sneti(i) = (sfcnsw(i) - ffw(i)*snetw) / fice(i) + + t12 = tice(i) * tice(i) + t14 = t12 * t12 + +!> - Calculate net non-solar and upir heat flux @ ice surface \a hfi. + +#ifdef GSD_SURFACE_FLUXES_BUGFIX + hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & + & + rch(i)*(tice(i)/prsik1(i) - theta1(i)) +#else + hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & + & + rch(i)*(tice(i) - theta1(i)) +#endif +!> - Calculate heat flux derivative at surface \a hfd. + hfd(i) = 4.0_kind_phys*sfcemis(i)*sbc*tice(i)*t12 & + & + (one + elocp*eps*hvap*qs1/(rd*t12)) * rch(i) + + t12 = tgice * tgice + t14 = t12 * t12 + +! --- ... hfw = net heat flux @ water surface (within ice) + +! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & +! & + rch(i)*(tgice - theta1(i)) - snetw + +!> - Assigin heat flux from ocean \a focn and snowfall rate as constants, which +!! should be from ocean model and other physics. + focn(i) = 2.0_kind_phys ! heat flux from ocean - should be from ocn model + snof(i) = zero ! snowfall rate - snow accumulates in gbphys + +!> - Initialize snow depth \a snowd. + hice(i) = max( min( hice(i), himax ), himin ) + snowd(i) = min( snowd(i), hsmax ) + + if (snowd(i) > (2.0_kind_phys*hice(i))) then +! print *, 'warning: too much snow :',snowd(i) + snowd(i) = hice(i) + hice(i) +! print *,'fix: decrease snow depth to:',snowd(i) + endif + endif + enddo + +!> - Call the three-layer thermodynamics sea ice model ice3lay(). + call ice3lay +! --- inputs: ! + & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! + & lprnt, ipr, +! --- outputs: ! + & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! + + do i = 1, im + if (flag(i)) then + if (tice(i) < timin) then + print *,'warning: snow/ice temperature is too low:',tice(i) + &, ' i=',i,' me=',me + tice(i) = timin + print *,'fix snow/ice temperature: reset it to:',tice(i) + endif + + if (stsice(i,1) < timin) then + write(0,*)'warning: layer 1 ice temp is too low:',stsice(i,1) + &, ' i=',i,' me=',me + &,' xlon_d=',xlon_d(i),' xlat_d=',xlat_d(i) + stsice(i,1) = timin + print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) + endif + + if (stsice(i,2) < timin) then + print *,'warning: layer 2 ice temp is too low:',stsice(i,2) + stsice(i,2) = timin + print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) + endif + + endif + enddo + + do k = 1, kice + do i = 1, im + if (flag(i)) then + tiice(i,k) = min(stsice(i,k), t0c) + endif + enddo + enddo + + do i = 1, im + if (flag(i)) then +! --- ... calculate sensible heat flux (& evap over sea ice) + +#ifdef GSD_SURFACE_FLUXES_BUGFIX + hflxi = rch(i) * (tice(i)/prsik1(i) - theta1(i)) + hflxw = rch(i) * (tgice / prsik1(i) - theta1(i)) +#else + hflxi = rch(i) * (tice(i) - theta1(i)) + hflxw = rch(i) * (tgice - theta1(i)) +#endif + hflx(i) = fice(i)*hflxi + ffw(i)*hflxw + evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + tskin(i) = fice(i)*tice(i) + ffw(i)*tgice +! +! --- ... the rest of the output + + qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) + +! --- ... convert snow depth back to mm of water equivalent + + weasd(i) = snowd(i) * 1000.0_kind_phys + snwdph(i) = weasd(i) * dsi ! snow depth in mm + + tem = one / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo +! + return +!! @} + +! ================= + contains +! ================= + + +!----------------------------------- +!> This subroutine is the entity of three-layer sea ice vertical thermodynamics +!! based on Winton(2000) \cite winton_2000 . +!!\ingroup gfs_sice_main +!\param[in] im integer, horizontal dimension +!\param[in] kmi integer, number of ice layers (2) +!\param[in] fice real, sea-ice concentration +!\param[in] flag logical, ice mask flag +!\param[in] hfi real, net non-solar and heat flux at surface (\f$W/m^2\f$) +!\param[in] hfd real, heat flux derivative at surface +!\param[in] sneti real, net solar incoming at top (\f$W/m^2\f$) +!\param[in] focn real, heat flux from ocean (\f$W/m^2\f$) +!\param[in] delt real, time step(\f$sec\f$) +!\param[in,out] snowd real, snow depth +!\param[in,out] hice real, sea-ice thickness +!\param[in,out] stsice real, temperature at mid-point of ice levels (\f$^oC\f$) +!\param[in,out] tice real, surface temperature (\f$^oC\f$) +!\param[in,out] snof real, snowfall rate (\f$ms^{-1}\f$) +!\param[out] snowmt real, snow melt during delt (\f$m\f$) +!\param[out] gflux real, conductive heat flux (\f$W/m^2\f$) +!>\section gen_ice3lay Three-layer Thermodynamics Sea Ice Model General Algorithm +!> @{ + subroutine ice3lay +!................................... +! --- inputs: + & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, & + & lprnt, ipr, +! --- input/outputs: + & snowd, hice, stsice, tice, snof, & +! --- outputs: + & snowmt, gflux & + & ) + +!************************************************************************** +! * +! three-layer sea ice vertical thermodynamics * +! * +! based on: m. winton, "a reformulated three-layer sea ice model", * +! journal of atmospheric and oceanic technology, 2000 * +! * +! * +! -> +---------+ <- tice - diagnostic surface temperature ( <= 0c )* +! / | | * +! snowd | snow | <- 0-heat capacity snow layer * +! \ | | * +! => +---------+ * +! / | | * +! / | | <- t1 - upper 1/2 ice temperature; this layer has * +! / | | a variable (t/s dependent) heat capacity * +! hice |...ice...| * +! \ | | * +! \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity) * +! \ | | * +! -> +---------+ <- base of ice fixed at seawater freezing temp. * +! * +! ===================== defination of variables ===================== ! +! ! +! inputs: size ! +! im, kmi - integer, horiz dimension and num of ice layers 1 ! +! fice - real, sea-ice concentration im ! +! flag - logical, ice mask flag 1 ! +! hfi - real, net non-solar and heat flux @ surface(w/m^2) im ! +! hfd - real, heat flux derivatice @ sfc (w/m^2/deg-c) im ! +! sneti - real, net solar incoming at top (w/m^2) im ! +! focn - real, heat flux from ocean (w/m^2) im ! +! delt - real, timestep (sec) 1 ! +! ! +! input/outputs: ! +! snowd - real, surface pressure im ! +! hice - real, sea-ice thickness im ! +! stsice - real, temp @ midpt of ice levels (deg c) im,kmi! +! tice - real, surface temperature (deg c) im ! +! snof - real, snowfall rate (m/sec) im ! +! ! +! outputs: ! +! snowmt - real, snow melt during delt (m) im ! +! gflux - real, conductive heat flux (w/m^2) im ! +! ! +! locals: ! +! hdi - real, ice-water interface (m) ! +! hsni - real, snow-ice (m) ! +! ! +! ======================================================================= ! +! + +! --- constant parameters: (properties of ice, snow, and seawater) + real (kind=kind_phys), parameter :: ds = 330.0_kind_phys !< snow (ov sea ice) density (kg/m^3) + real (kind=kind_phys), parameter :: dw =1000.0_kind_phys !< fresh water density (kg/m^3) + real (kind=kind_phys), parameter :: dsdw = ds/dw + real (kind=kind_phys), parameter :: dwds = dw/ds + real (kind=kind_phys), parameter :: ks = 0.31_kind_phys !< conductivity of snow (w/mk) + real (kind=kind_phys), parameter :: i0 = 0.3_kind_phys !< ice surface penetrating solar fraction + real (kind=kind_phys), parameter :: ki = 2.03_kind_phys !< conductivity of ice (w/mk) + real (kind=kind_phys), parameter :: di = 917.0_kind_phys !< density of ice (kg/m^3) + real (kind=kind_phys), parameter :: didw = di/dw + real (kind=kind_phys), parameter :: dsdi = ds/di + real (kind=kind_phys), parameter :: ci = 2054.0_kind_phys !< heat capacity of fresh ice (j/kg/k) + real (kind=kind_phys), parameter :: li = 3.34e5_kind_phys !< latent heat of fusion (j/kg-ice) + real (kind=kind_phys), parameter :: si = 1.0_kind_phys !< salinity of sea ice + real (kind=kind_phys), parameter :: mu = 0.054_kind_phys !< relates freezing temp to salinity + real (kind=kind_phys), parameter :: tfi = -mu*si !< sea ice freezing temp = -mu*salinity + real (kind=kind_phys), parameter :: tfw = -1.8_kind_phys !< tfw - seawater freezing temp (c) + real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001_kind_phys + real (kind=kind_phys), parameter :: dici = di*ci + real (kind=kind_phys), parameter :: dili = di*li + real (kind=kind_phys), parameter :: dsli = ds*li + real (kind=kind_phys), parameter :: ki4 = ki*4.0_kind_phys + real (kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + +! --- inputs: + integer, intent(in) :: im, kmi, ipr + logical :: lprnt + + real (kind=kind_phys), dimension(im), intent(in) :: fice, hfi, & + & hfd, sneti, focn + + real (kind=kind_phys), intent(in) :: delt + + logical, dimension(im), intent(in) :: flag + +! --- input/outputs: + real (kind=kind_phys), dimension(im), intent(inout) :: snowd, & + & hice, tice, snof + + real (kind=kind_phys), dimension(im,kmi), intent(inout) :: stsice + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(out) :: snowmt, & + & gflux + +! --- locals: + + real (kind=kind_phys) :: dt2, dt4, dt6, h1, h2, dh, wrk, wrk1, & + & dt2i, hdi, hsni, ai, bi, a1, b1, a10, b10& + &, c1, ip, k12, k32, tsf, f1, tmelt, bmelt + + integer :: i +! +!===> ... begin here +! + dt2 = delt + delt + dt4 = dt2 + dt2 + dt6 = dt2 + dt4 + dt2i = one / dt2 + + do i = 1, im + if (flag(i)) then + snowd(i) = snowd(i) * dwds + hdi = (dsdw*snowd(i) + didw*hice(i)) + + if (hice(i) < hdi) then + snowd(i) = snowd(i) + hice(i) - hdi + hsni = (hdi - hice(i)) * dsdi + hice (i) = hice(i) + hsni + endif + + snof(i) = snof(i) * dwds + tice(i) = tice(i) - t0c ! convert from K to C + stsice(i,1) = min(stsice(i,1)-t0c, tfi0) ! degc + stsice(i,2) = min(stsice(i,2)-t0c, tfi0) ! degc + + if (lprnt .and. i == ipr) write(0,*)' in ice3stsice=',stsice(i,:),& + &' snowd=',snowd(i) + ip = i0 * sneti(i) ! ip +v (in winton ip=-i0*sneti as sol -v) + if (snowd(i) > zero) then + tsf = zero + ip = zero + else + tsf = tfi + ip = i0 * sneti(i) ! ip +v here (in winton ip=-i0*sneti) + endif + tice(i) = min(tice(i), tsf) + +!> - Ice temperature calculation. + + bi = hfd(i) + ai = hfi(i) - sneti(i) + ip - tice(i)*bi ! +v sol input here +!> - Calculate the effective conductive coupling of the snow-ice layer +!! between the surface and the upper layer ice temperature \f$h_i/4\f$ +!! beneath the snow-ice interface (see \a eq.(5) in Winton (2000) \cite winton_2000). + k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) + +!> - Calculate the conductive coupling between the two ice temperature +!! points (see \a eq.(10) in Winton (2000) \cite winton_2000). + k32 = (ki+ki) / hice(i) + + wrk = one / (dt6*k32 + dici*hice(i)) + a10 = dici*hice(i)*dt2i + k32*(dt4*k32 + dici*hice(i))*wrk + b10 = -di*hice(i) * (ci*stsice(i,1) + li*tfi/stsice(i,1)) & + & * dt2i - ip & + & - k32*(dt4*k32*tfw + dici*hice(i)*stsice(i,2)) * wrk + + wrk1 = k12 / (k12 + bi) + a1 = a10 + bi * wrk1 + b1 = b10 + ai * wrk1 + c1 = dili * tfi * dt2i * hice(i) + +!> - Calculate the new upper ice temperature following \a eq.(21) +!! in Winton (2000) \cite winton_2000. + stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1)/(a1+a1) + tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) + + if (lprnt .and. i == ipr) write(0,*)' ice3stsice1=',stsice(i,1), & + &' hice=',hice(i),' sneti=',sneti(i),' abc=',a1,b1,c1,' k12=',k12 + +!> - If the surface temperature is greater than the freezing temperature +!! of snow (when there is snow over) or sea ice (when there is none), the +!! surface temperature is fixed at the melting temperature of snow or sea +!! ice, respectively, and the upper ice temperature is recomputed from +!! \a eq.(21) using the coefficients given by \a eqs. (19),(20), and (18). An energy flux +!! \a eq.(22) is applied toward surface melting thereby balancing the surface +!! energy budget. + if (tice(i) > tsf) then + a1 = a10 + k12 + b1 = b10 - k12*tsf + stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1) & + & / (a1+a1) + tice(i) = tsf + tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt + else + tmelt =zero + snowd(i) = snowd(i) + snof(i)*delt + endif +!> - Calculate the new lower ice temperature following \a eq.(15) +!! in Winton (2000) \cite winton_2000. + stsice(i,2) = (dt2*k32*(stsice(i,1) + tfw + tfw) & + & + dici*hice(i)*stsice(i,2)) * wrk + +!> - Calculate the energy for bottom melting (or freezing, if negative) +!! following \a eq.(23), which serves to balance the difference between +!! the oceanic heat flux to the ice bottom and the conductive flux of +!! heat upward from the bottom. + bmelt = (focn(i) + ki4*(stsice(i,2) - tfw)/hice(i)) * delt + +!> - Calculation of ice and snow mass changes. + + h1 = 0.5_kind_phys * hice(i) + h2 = 0.5_kind_phys * hice(i) + + if (lprnt .and. i == ipr) write(0,*)' hi2ice=',h1,h2,hice(i) +!> - Calculate the top layer thickness. + + if (tmelt <= snowd(i)*dsli) then + snowmt(i) = tmelt / dsli + snowd (i) = snowd(i) - snowmt(i) + else + snowmt(i) = snowd(i) + h1 = max(zero, h1 - (tmelt - snowd(i)*dsli) & + & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1)))) + snowd(i) = zero + endif + +! --- ... and bottom +!> - When the energy for bottem melting \f$M_b\f$ is negative (i.e., freezing +!! is happening),calculate the bottom layer thickness \f$h_2\f$ and the new +!! lower layer temperature (see \a eqs.(24)-(26)). + if (bmelt < zero) then + dh = -bmelt / (dili + dici*(tfi - tfw)) + stsice(i,2) = (h2*stsice(i,2) + dh*tfw) / (h2 + dh) + h2 = h2 + dh + else + h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) + endif + h2 = max(h2,zero) + +!> - If ice remains, even up 2 layers, else, pass negative energy back in snow. +!! Calculate the new upper layer temperature (see \a eq.(38)). + + hice(i) = h1 + h2 + + if (lprnt .and. i == ipr) & + & write(0,*)' h12=',h1,h2,' hice=',hice(ipr) + + if (hice(i) > zero) then + if (h1 > 0.5_kind_phys*hice(i)) then + f1 = one - (h2+h2) / hice(i) + stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& + & + (one - f1)*stsice(i,2) + + if (stsice(i,2) > tfi) then + hice(i) = hice(i) - h2*ci*(stsice(i,2) - tfi)/ (li*delt) + stsice(i,2) = tfi + endif + else + f1 = (h1+h1) / hice(i) + if (lprnt .and. i == ipr) write(0,*)' stsb=',stsice(i,1),' f1=', & + &f1,' sts2=',stsice(i,2),' litfifac=',li*tfi/(ci*stsice(i,1)) + stsice(i,1) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& + & + (one - f1)*stsice(i,2) + if (lprnt .and. i == ipr) write(0,*)' stsa=',stsice(i,1),' tfi=', & + &tfi,'li=',li,' ci=',ci,' tice=',tice(i) + stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & + & - 4.0_kind_phys*tfi*li/ci)) * 0.5_kind_phys + endif + + k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) + gflux(i) = k12 * (stsice(i,1) - tice(i)) + else + snowd(i) = snowd(i) + (h1*(ci*(stsice(i,1) - tfi) & + & - li*(one - tfi/stsice(i,1))) & + & + h2*(ci*(stsice(i,2) - tfi) - li)) / li + + hice(i) = max(zero, snowd(i)*dsdi) + snowd(i) = zero + stsice(i,1) = tfw + stsice(i,2) = tfw + gflux(i) = zero + endif ! end if_hice_block + + gflux(i) = fice(i) * gflux(i) + snowmt(i) = snowmt(i) * dsdw + snowd(i) = snowd(i) * dsdw + tice(i) = tice(i) + t0c + stsice(i,1) = stsice(i,1) + t0c + stsice(i,2) = stsice(i,2) + t0c + endif ! end if_flag_block + enddo ! end do_i_loop + + if (lprnt) write(0,*)' ice3endstsice=',stsice(ipr,:) + return +!................................... + end subroutine ice3lay +!> @} +!----------------------------------- + +! =========================== ! +! end contain programs ! +! =========================== ! + +!................................... + end subroutine sfc_sice_run +!----------------------------------- +!> @} + end module sfc_sice diff --git a/physics/debug/sfc_sice.meta_dbg b/physics/debug/sfc_sice.meta_dbg new file mode 100644 index 000000000..e8143dcc5 --- /dev/null +++ b/physics/debug/sfc_sice.meta_dbg @@ -0,0 +1,478 @@ +[ccpp-table-properties] + name = sfc_sice + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## +[ccpp-arg-table] + name = sfc_sice_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[kice] + standard_name = ice_vertical_dimension + long_name = vertical loop extent for ice levels, start at 1 + units = count + dimensions = () + type = integer + intent = in + optional = F +[sbc] + standard_name = stefan_boltzmann_constant + long_name = Stefan-Boltzmann constant + units = W m-2 K-4 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tgice] + standard_name = freezing_point_temperature_of_seawater + long_name = freezing point temperature of seawater + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[epsm1] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one + long_name = (rd/rv) - 1 + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rvrdm1] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[grav] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degree Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = surface layer mean temperature + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = surface layer mean specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_dynamics + long_name = time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[sfcemis] + standard_name = surface_longwave_emissivity_over_ice_interstitial + long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[dlwflx] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice + long_name = total sky surface downward longwave flux absorbed by the ground over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfcnsw] + standard_name = surface_net_downwelling_shortwave_flux + long_name = total sky sfc netsw flx into ground + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[sfcdsw] + standard_name = surface_downwelling_shortwave_flux + long_name = total sky sfc downward sw flux + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[srflag] + standard_name = flag_for_precipitation_type + long_name = snow/rain flag for precipitation + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice + long_name = surface exchange coeff for momentum over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice + long_name = surface exchange coeff heat & moisture over ice + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = surface layer mean pressure + units = Pa + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslki] + standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer + long_name = Exner function ratio bt midlayer and interface at 1st layer + units = ratio + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prsik1] + standard_name = dimensionless_exner_function_at_lowest_model_interface + long_name = dimensionless Exner function at the ground surface + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[prslk1] + standard_name = dimensionless_exner_function_at_lowest_model_layer + long_name = dimensionless Exner function at the lowest model layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[wind] + standard_name = wind_speed_at_lowest_model_layer + long_name = wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = switch for printing sample column to stdout + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of printed column + units = index + dimensions = () + type = integer + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[hice] + standard_name = sea_ice_thickness + long_name = sea-ice thickness + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = sea-ice concentration [0,1] + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tice] + standard_name = sea_ice_temperature_interstitial + long_name = sea-ice surface temperature use as interstitial + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tskin] + standard_name = surface_skin_temperature_over_ice_interstitial + long_name = surface skin temperature over ice (temporary use as interstitial) + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tprcp] + standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice + long_name = total precipitation amount in each time step over ice + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[tiice] + standard_name = internal_ice_temperature + long_name = sea ice internal temperature + units = K + dimensions = (horizontal_loop_extent,ice_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[qsurf] + standard_name = surface_specific_humidity_over_ice + long_name = surface air saturation specific humidity over ice + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[snowmt] + standard_name = surface_snow_melt + long_name = snow melt during timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[gflux] + standard_name = upward_heat_flux_in_soil_over_ice + long_name = soil heat flux over ice + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice + long_name = momentum exchange coefficient over ice + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice + long_name = thermal exchange coefficient over ice + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_ice + long_name = kinematic surface upward latent heat flux over ice + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice + long_name = kinematic surface upward sensible heat flux over ice + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[islmsk_cice] + standard_name = sea_land_ice_mask_cice + long_name = sea/land/ice mask cice (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[xlat_d] + standard_name = latitude_in_degree + long_name = latitude in degree north + units = degree_north + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/debug/sfcsub.F_dbg b/physics/debug/sfcsub.F_dbg new file mode 100644 index 000000000..e15e5c463 --- /dev/null +++ b/physics/debug/sfcsub.F_dbg @@ -0,0 +1,8772 @@ +!>\file sfcsub.F +!! This file contains gribcode for each parameter. + + +!>\defgroup mod_sfcsub GFS sfcsub Module +!!\ingroup LSMs +!> @{ +!! This module contains grib code for each parameter-used in subroutines sfccycle() +!! and setrmsk(). + module sfccyc_module + use machine , only : kind_io8,kind_io4 + 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/) +! + real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 + integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer :: veg_type_landice + integer :: soil_type_landice + integer :: num_threads +! +! + contains + + function message(prefix,index) + implicit none + character(len=*), intent(in) :: prefix + integer, intent(in) :: index + ! Safety measure: prevent writing out of bounds, use a longer string than 8 characters + character(len=16) :: message + write(message,fmt='(a,a,i0)') trim(prefix), '-', index + end function message + + end module sfccyc_module + +!>\ingroup mod_GFS_phys_time_vary +!! 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 & + &, slmskl,slmskw,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,nthrds,nlunit & + &, sz_nml,input_nml_file & + &, min_ice & + &, 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), & + & me, nthrds + logical, intent(in) :: use_ufo, nst_anl + real (kind=kind_io8), intent(in) :: min_ice(len) + + 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,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) +! +!> 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=' ' +! +! +! 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,sicjmx=1.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 + 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, zero=0.0 + real (kind=kind_io8), parameter :: crit_lnd=1.0e-6, & + & crit_wat=1.0e-6 +! +! coefficients of blending forecast and interpolated clim +! (or analyzed) fields over sea or land(l) (not for clouds) +! 1.0 = use of forecast +! 0.0 = replace with interpolated analysis +! +! these values are set for analysis mode. +! +! variables land sea +! --------------------------------------------------------- +! surface temperature forecast analysis +! surface temperature forecast forecast (over sea ice) +! albedo forecast/analysis analysis +! sea-ice analysis analysis +! snow forecast/analysis forecast (over sea ice) +! roughness forecast/analysis forecast +! plant resistance analysis analysis +! soil wetness (layer) weighted average analysis +! soil temperature forecast analysis +! 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 forecast/analysis-weighted analysis +! +! note: if analysis file is not given, then time interpolated climatology +! is used. if analyiss file is given, it will be used as far as the +! 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) slmskl(len), slmskw(len) + real (kind=kind_io8) 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) +! + real (kind=kind_io8), allocatable, dimension(:) :: & + & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & + & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & + & vmnfcsd, vmxfcsd, slpfcsd, absfcsd + real (kind=kind_io8), allocatable, dimension(:,:) :: & + & smcfcsd, stcfcsd, albfcsd +! +! 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(lsoil) +! rec. 5 snow +! rec. 6 soilt(lsoil) +! 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 (lsoil) +! 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, 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 +! Set number of threads num_threads in sfccyc_module for later use +! to the value received from the calling routine (nthrds) + num_threads = nthrds +! + lprnt = .false. + 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) + 66.35) + tem2 = abs(rlo(i) - 109.01) + if(tem1 < 0.10 .and. tem2 < 0.10) 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 + elseif (ialb ==2) 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 == 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 == 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 >= 99999.) ctsfl = 1. + if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) +! + ctsfs=0. !... tsfc over sea + if (ftsfs >= 99999.) ctsfs=1. + if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) +! + do k=1,lsoil + csmcl(k) = 0. !... soilm over land + if (fsmcl(k) >= 99999.) csmcl(k) = 1. + if (fsmcl(k) > 0. .and. fsmcl(k) < 99999) + & csmcl(k) = exp(-deltf/fsmcl(k)) + csmcs(k)=0. !... soilm over sea + if (fsmcs(k) >= 99999.) csmcs(k) = 1. + if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) + & csmcs(k) = exp(-deltf/fsmcs(k)) + enddo +! + calbl = 0. !... albedo over land + if (ialb == 2) falbl=99999. + if (falbl >= 99999.) calbl = 1. + if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) +! + calfl=0. !... fraction field for albedo over land + if (falfl >= 99999.) calfl = 1. + if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) +! + calbs=0. !... albedo over sea + if (falbs >= 99999.) calbs = 1. + if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) +! + calfs = 0. !... fraction field for albedo over sea + if (falfs >= 99999.) calfs = 1. + if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) +! + caisl = 0. !... sea ice over land + if (faisl >= 99999.) caisl = 1. + if (faisl > 0. .and. faisl < 99999) caisl = 1. +! + caiss = 0. !... sea ice over sea + if (faiss >= 99999.) caiss = 1. + if (faiss > 0. .and. faiss < 99999) caiss = 1. +! + csnol = 0. !... snow over land + if (fsnol >= 99999.) csnol = 1. + if (fsnol > 0. .and. fsnol < 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 < 0.) csnol = fsnol +! + csnos = 0. !... snow over sea + if (fsnos >= 99999.) csnos = 1. + if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) +! + czorl = 0. !... roughness length over land + if (fzorl >= 99999.) czorl = 1. + if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) +! + czors = 0. !... roughness length over sea + if (fzors >= 99999.) czors = 1. + if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) +! +! cplrl = 0. !... plant resistance over land +! if (fplrl >= 99999.) cplrl = 1. +! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) +! +! cplrs = 0. !... plant resistance over sea +! if (fplrs >= 99999.) cplrs = 1. +! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) +! + do k=1,lsoil + cstcl(k) = 0. !... soilt over land + if (fstcl(k) >= 99999.) cstcl(k) = 1. + if (fstcl(k) > 0. .and. fstcl(k) < 99999) & + & cstcl(k) = exp(-deltf/fstcl(k)) + cstcs(k) = 0. !... soilt over sea + if (fstcs(k) >= 99999.) cstcs(k) = 1. + if (fstcs(k) > 0. .and. fstcs(k) < 99999) & + & cstcs(k) = exp(-deltf/fstcs(k)) + enddo +! + cvegl = 0. !... vegetation fraction over land + if (fvegl >= 99999.) cvegl = 1. + if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) +! + cvegs = 0. !... vegetation fraction over sea + if (fvegs >= 99999.) cvegs = 1. + if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) +! + cvetl = 0. !... vegetation type over land + if (fvetl >= 99999.) cvetl = 1. + if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) +! + cvets = 0. !... vegetation type over sea + if (fvets >= 99999.) cvets = 1. + if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) +! + csotl = 0. !... soil type over land + if (fsotl >= 99999.) csotl = 1. + if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) +! + csots = 0. !... soil type over sea + if (fsots >= 99999.) csots = 1. + if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) + +!cwu [+16l]--------------------------------------------------------------- +! + csihl = 0. !... sea ice thickness over land + if (fsihl >= 99999.) csihl = 1. + if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) +! + csihs = 0. !... sea ice thickness over sea + if (fsihs >= 99999.) csihs = 1. + if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) +! + csicl = 0. !... sea ice concentration over land + if (fsicl >= 99999.) csicl = 1. + if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) +! + csics = 0. !... sea ice concentration over sea + if (fsics >= 99999.) csics = 1. + if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) + +!clu [+32l]--------------------------------------------------------------- +! + cvmnl = 0. !... min veg cover over land + if (fvmnl >= 99999.) cvmnl = 1. + if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) +! + cvmns = 0. !... min veg cover over sea + if (fvmns >= 99999.) cvmns = 1. + if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) +! + cvmxl = 0. !... max veg cover over land + if (fvmxl >= 99999.) cvmxl = 1. + if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) +! + cvmxs = 0. !... max veg cover over sea + if (fvmxs >= 99999.) cvmxs = 1. + if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) +! + cslpl = 0. !... slope type over land + if (fslpl >= 99999.) cslpl = 1. + if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) +! + cslps = 0. !... slope type over sea + if (fslps >= 99999.) cslps = 1. + if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) +! + cabsl = 0. !... snow albedo over land + if (fabsl >= 99999.) cabsl = 1. + if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) +! + cabss = 0. !... snow albedo over sea + if (fabss >= 99999.) cabss = 1. + if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) +!clu ---------------------------------------------------------------------- +! +!> - 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) +! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) +! + if (me == 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)) +! +! do i=1,len +! if (landfrac(i) > crit_lnd) then +! slmskl(i) = one +! slmskw(i) = one +! if (one-landfrac(i) > crit_wat) then +! slmskw(i) = zero +! if (sicfcs(i) > min_ice(i)) then +! slmskw(i) = 2.0_kind_io8 +! endif +! endif +! else +! slmskl(i) = zero +! slmskw(i) = zero +! if (sicfcs(i) > min_ice(i)) then +! slmskl(i) = 2.0_kind_io8 +! slmskw(i) = 2.0_kind_io8 +! endif +! endif +! if (i == 1) write(0,*)' landfrac=',landfrac(i),' slmskl=', & +! if (i == 1) write(0,*)' slmskl=', slmskl(i),' slmskw=', & +! & slmskw(i),' sicfcs=',sicfcs(i) +! enddo + +! write(1000+me,*)' slmskl=',slmskl +! write(1000+me,*)' slmskw=',slmskw +! +! read glacier +! + kpd9 = -1 + kpd7 = -1 + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl + &, 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,slmskl + &, 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,slmskl,slmskw, + & 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,slmskl,albomx,len) +! +! make sure vegetation type and soil type are non zero over land +! + call landtyp(vetclm,sotclm,slpclm,slmskl,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) /= ' ') then +!cwu [+5l/-1l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*aisclm(i) + sicclm(i) = aisclm(i) + if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i) /= 1.0) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim +!* crit=0.5 +! call rof01(aisclm,len,'ge',crit) + call rof01_len(aisclm, len, 'ge', min_ice) + + elseif(fnacnc(1:8) /= ' ') then +!cwu [+4l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*acnclm(i) + sicclm(i) = acnclm(i) + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i).ne.1.) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo +! call rof01(acnclm,len,'ge',aislim) + call rof01_len(acnclm, len, 'ge', min_ice) + do i=1,len + aisclm(i) = acnclm(i) + enddo + endif +! +! quality control of sea ice mask +! + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmskw,aisclm,len,aicice,sliclm) + + if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' + *,sliclm(iprnt),' slmskw=',slmskw(iprnt) +! +! write(6,*) 'sliclm' +! znnt=1. +! call nntprt(sliclm,len,znnt) +! +! quality control of snow +! + call qcsnow(snoclm,slmskl,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) > 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) +! + !-- soil moisture + if(fnsmcc(1:8).eq.' ') then + call getsmc(wetclm,len,lsoil,smcclm,me) + endif + do k=1,lsoil + call qcmxmn(message('stc',k),smcclm(1,k),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + !-- soil temperature + if(fnstcc(1:8).eq.' ') then + call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) + endif + do k=1,lsoil + call qcmxmn(message('stc',k),stcclm(1,k),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + 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 == 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) + do k=1,lsoil + call monitr(message('smcclm',k),smcclm(1,k),sliclm,snoclm,len) + call monitr(message('stcclm',k),stcclm(1,k),sliclm,snoclm,len) + enddo + call monitr('tg3clm',tg3clm,sliclm,snoclm,len) + call monitr('zorclm',zorclm,sliclm,snoclm,len) +! if (gaus) then + 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 == 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,slmskl,slmskw, + & 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,slmskw,ztsfc,len,rlapse) + endif +! +! ice concentration or ice mask (only ice mask used in the model now) +! + if(fnaisa(1:8) /= ' ') then +!cwu [+5l/-1l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*aisanl(i) + sicanl(i) = aisanl(i) + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo +! crit=aislim +!* crit=0.5 +! call rof01(aisanl,len,'ge',crit) + call rof01_len(aisanl, len, 'ge', min_ice) + elseif(fnacna(1:8) /= ' ') then +!cwu [+17l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*acnanl(i) + sicanl(i) = acnanl(i) + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo +! crit=aislim + do i=1,len + crit = min_ice(i) + if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then + slianl(i) = 2.0_kind_io8 +! print *,'cycle - new ice form: fice=',sicanl(i) + elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then + slianl(i) = 0. +! print *,'cycle - ice free: fice=',sicanl(i) + elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then + if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid + slianl(i) = 2.0_kind_io8 + else +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i) = 0.0_kind_io8 + endif + 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) + call rof01_len(acnanl, len, 'ge', min_ice) + do i=1,len + aisanl(i) = acnanl(i) + enddo + endif + if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' + &,glacir(iprnt),' slmskw=',slmskw(iprnt) +! + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmskw,aisanl,len,aicice,slianl) + if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' + *,slianl(iprnt),' slmskw=',slmskw(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,slmskl,albomx,len) +! +! quality control of snow and sea-ice +! process snow depth or snow cover +! + if (fnsnoa(1:8) /= ' ') then + call setzro(snoanl,epssno,len) + call qcsnow(snoanl,slmskl,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,slmskl,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,slmskl,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) > 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) /= ' ' .or. fnweta(1:8) /= ' ' ) 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) == ' ' .and. fnsmcc(1:8) == ' ') then + call getsmc(wetanl,len,lsoil,smcanl,me) + endif + !-- soil moisture + do k=1,lsoil + call qcmxmn(message('smca',k),smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + !-- soil temperature + if(fnstca(1:8).eq.' ') then + call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) + endif + do k=1,lsoil + call qcmxmn(message('stca',k),stcanl(1,1),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + 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 == 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) + do k=1,lsoil + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) + enddo + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) +! if (gaus) then + 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 == 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 == 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) /= 0.) then + call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, + & tsfimx) + do i=1,len + icefl2(i) = sicfcs(i) > 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,slmskl,ztsfc,len,-rlapse) + endif + ztsfc = 0. + call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse) + else + ztsfc = 0. + call tsfcor(tsffcs,orog,slmskw,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) /= 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo + enddo +!clu ----------------------------------------------------------------------- +! + if (lqcbgs .and. irtacn == 0) then + call qcsli(slianl,slifcs,len,me) + call albocn(albfcs,slmskl,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) /= ' ' .or. fnweta(1:8) /= ' ' ) + & 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) +!-- soil moisture forecast + do k=1,lsoil + call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs, + & snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo +!-- soil temperature forecast + do k=1,lsoil + call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs, + & snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + 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 == 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) + do k=1,lsoil + call monitr(message('smcfcs',k),smcfcs(1,k),slifcs,snofcs,len) + call monitr(message('stcfcs',k),stcfcs(1,k),slifcs,snofcs,len) + enddo + call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) + call monitr('zorfcs',zorfcs,slifcs,snofcs,len) +! if (gaus) then + 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) + + do i=1,len + if (sicanl(i) >= min_ice(i)) then + slianl(i) = 2.0_kind_io8 + else + slianl(i) = zero + sicanl(i) = zero + endif + enddo + + 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 == 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 +! + if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:) + if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:) + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & slmskl,slmskw,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) + if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:) + if(lprnt) print *,' stcanlmer=',stcanl(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) + if(lprnt) print *,' stcan=',stcanl(iprnt,:) +! +! set tsfc to tsnow over snow +! + call snosfc(snoanl,tsfanl,tsfsmx,len,me) +! + do i=1,len + icefl2(i) = sicanl(i) > 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) /= ' ' .or. fnweta(1:8) /= ' ') 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 + do k=1,lsoil + call qcmxmn(message('stcm',k),stcanl(1,k),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + do k=1,lsoil + call qcmxmn(message('smcm',k),smcanl(1,k),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + 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 == 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,slmskl,ztsfc,len,rlapse) + endif + ztsfc = 0. + call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse) + else + ztsfc = 0. + call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse) + endif + if(lprnt) print *,' tsfaf=',tsfanl(iprnt) +! +! check the final merged product +! + if (monmer) then + if(me == 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) + do k=1,lsoil + call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) + enddo + if (lsoil > 2) then + call monitr('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 + allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), & + & zorfcsd(len), slifcsd(len), aisfcsd(len), & + & cnpfcsd(len), vegfcsd(len), vetfcsd(len), & + & sotfcsd(len), sihfcsd(len), sicfcsd(len), & + & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & + & absfcsd(len)) + allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & + & albfcsd(len,4)) + do i=1,len + tsffcsd(i) = tsfanl(i) - tsffcs(i) + snofcsd(i) = snoanl(i) - snofcs(i) + tg3fcsd(i) = tg3anl(i) - tg3fcs(i) + zorfcsd(i) = zoranl(i) - zorfcs(i) +! plrfcs(i) = plranl(i) - plrfcs(i) +! albfcs(i) = albanl(i) - albfcs(i) + slifcsd(i) = slianl(i) - slifcs(i) + aisfcsd(i) = aisanl(i) - aisfcs(i) + cnpfcsd(i) = cnpanl(i) - cnpfcs(i) + vegfcsd(i) = veganl(i) - vegfcs(i) + vetfcsd(i) = vetanl(i) - vetfcs(i) + sotfcsd(i) = sotanl(i) - sotfcs(i) +!clu [+2l] add sih, sic + sihfcsd(i) = sihanl(i) - sihfcs(i) + sicfcsd(i) = sicanl(i) - sicfcs(i) +!clu [+4l] add vmn, vmx, slp, abs + vmnfcsd(i) = vmnanl(i) - vmnfcs(i) + vmxfcsd(i) = vmxanl(i) - vmxfcs(i) + slpfcsd(i) = slpanl(i) - slpfcs(i) + absfcsd(i) = absanl(i) - absfcs(i) + enddo + do j = 1,lsoil + do i = 1,len + smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcsd(i,j) = stcanl(i,j) - stcfcs(i,j) + enddo + enddo + do j = 1,4 + do i = 1,len + albfcsd(i,j) = albanl(i,j) - albfcs(i,j) + enddo + enddo +! +! monitoring prints +! + if(me == 0) then + print *,' ' + print *,'monitor of difference' + print *,' (includes angulation correction)' + print *,' ' + call monitr('tsfdif', tsffcsd,slianl,snoanl,len) + call monitr('albdif', albfcsd,slianl,snoanl,len) + call monitr('albdif1',albfcsd,slianl,snoanl,len) + call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len) + call monitr('aisdif', aisfcsd,slianl,snoanl,len) + call monitr('snodif', snofcsd,slianl,snoanl,len) + do k=1,lsoil + call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len) + enddo + call monitr('tg3dif',tg3fcsd,slianl,snoanl,len) + call monitr('zordif',zorfcsd,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',slifcsd,slianl,snoanl,len) +! call monitr('plrdif',plrfcs,slianl,snoanl,len) + call monitr('cnpdif',cnpfcsd,slianl,snoanl,len) + call monitr('vegdif',vegfcsd,slianl,snoanl,len) + call monitr('vetdif',vetfcsd,slianl,snoanl,len) + call monitr('sotdif',sotfcsd,slianl,snoanl,len) +!cwu [+2l] add sih, sic + call monitr('sihdif',sihfcsd,slianl,snoanl,len) + call monitr('sicdif',sicfcsd,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmndif',vmnfcsd,slianl,snoanl,len) + call monitr('vmxdif',vmxfcsd,slianl,snoanl,len) + call monitr('slpdif',slpfcsd,slianl,snoanl,len) + call monitr('absdif',absfcsd,slianl,snoanl,len) + endif + deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & + & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & + & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & + & absfcsd) + deallocate (smcfcsd, stcfcsd, albfcsd) + 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) > 0.0_kind_io8) then + stcfcs(i,j) = stcanl(i,j) + else + stcfcs(i,j) = tsffcs(i) + endif + enddo + enddo + if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', & + & slifcs(iprnt) + 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 + if (slmskw(i) == zero) then + crit = min_ice(i) + if (sicanl(i) >= crit) then + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (sicfcs(i) >= crit) then + tem1 = 1.0_kind_io8 / sicfcs(i) + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) + else + tsffcs(i) = tgice + sitfcs(i) = tgice + sicfcs(i) = sicanl(i) + sihfcs(i) = sihnew + endif + if (lprnt .and. i == iprnt) write(0,*)' sicanl=',sicanl(i), & + &' sicfcs=',sicfcs(i),' siccanl=',sicanl(i),' sihfcs=',sihfcs(i) + else + tsffcs(i) = tsfanl(i) + sihfcs(i) = 0.0_kind_io8 + sicfcs(i) = 0.0_kind_io8 + slifcs(i) = 0.0_kind_io8 + sitfcs(i) = tsffcs(i) + endif + endif + if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then + print *,'warning: check, slifcs and sicfcs', & + & slifcs(i),sicfcs(i) + endif + enddo + +! do i=1,len +! if (slifcs(i) < 1.5_kind_io8) then +! sihfcs(i) = 0.0_kind_io8 +! sicfcs(i) = 0.0_kind_io8 +! sitfcs(i) = tsffcs(i) +! else +! crit = min_ice(i) +! if (sicfcs(i) < crit) then +! print *,'warning: check, slifcs and sicfcs', & +! & slifcs(i),sicfcs(i) +! endif +! endif +! enddo + +! +! ensure the consistency between slc and smc +! + do k=1, lsoil + fixratio(k) = .false. + if (fsmcl(k) < 99999.) fixratio(k) = .true. + enddo + + if(me == 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) == -999.) then + slcfcs(i,k) = smcfcs(i,k) + else + slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) + endif + if (slifcs(i) /= 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) == 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 < 99999.) then + if(me == 0) then + print *,'dbgx -- scale snwdph from sheleg' + endif + do i = 1, len + if(slifcs(i) == 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) /= 1) swdfcs(i) = 3.*snofcs(i) + enddo + + do i = 1, len + if(slifcs(i) == 1.) then + if(snofcs(i) /= 0. .and. swdfcs(i) == 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) == 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) + if(lprnt) print *,' stcfcsend=',stcfcs(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 +!! 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 + 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 + use sfccyc_module , only : num_threads + 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(:) +! + 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 + data first /.true./ + save first +! + integer len_thread_m, len_thread, i1_t, i2_t +! + if (first) then + 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 & + &, ' slmask=',slmask(i),' me=',me & + &, ' outlon=',outlon(i),' outlat=',outlat(i) + &, '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, & + & 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) & + &, 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 + 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,slmskl,slmskw, & + & 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, & !cggg snow mods + & 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, & + & 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 +! + real (kind=kind_io8) slmskl(len), slmskw(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 + &, 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) & + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + logical gaus +! +! tsf +! + irttsf = 1 + if(fntsfa(1:8).ne.' ') then + call fixrda(lugb,fntsfa,kpdtsf,slmskw, + & 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,slmskw, + & 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),slmskl, + & iy,im,id,ih,fh,albanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalb = iret + if(iret == 1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret == -1) then + if (me == 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 == 0 .and. kk == 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me == 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),slmskl, + & iy,im,id,ih,fh,alfanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalf = iret + if(iret == 1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret == -1) then + if (me == 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 == 0 .and. kk == 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me == 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,slmskl, + & 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,slmskl, + & iy,im,id,ih,fh,smcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnsmca,kpdsmc,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskw, + & 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,slmskw, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & iy,im,id,ih,fh,stcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnstca,kpdstc,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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, & + & 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) & + &, 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', & + & ' 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 == 'ge') then + do i=1,len + if(aisfld(i) >= crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'gt') then + do i=1,len + if(aisfld(i) > crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'le') then + do i=1,len + if(aisfld(i) <= crit) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'lt') then + do i=1,len + if(aisfld(i) < 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 rof01_len(aisfld, len, op, crit) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8), intent(in) :: crit(len) + real (kind=kind_io8) aisfld(len) + character*2 op +! + if(op == 'ge') then + do i=1,len + if(aisfld(i) >= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'gt') then + do i=1,len + if(aisfld(i) > crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'le') then + do i=1,len + if(aisfld(i) <= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'lt') then + do i=1,len + if(aisfld(i) < crit(i)) 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 + +!>\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 + 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 +!! This subroutine merges analysis and forecast. + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & + & slmskl,slmskw,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, & + & num_threads, zero, one + 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) slmskl(len), slmskw(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) & + &, 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 + data first /.true./ + save first +! + integer len_thread_m, i1_t, i2_t, it +! + if (first) then + 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,rsics + 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.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) == zero) 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) == zero) then +! if(slmskw(i) == zero) 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 + endif + if(slmskl(i) == one .or. slianl(i) > zero) then + 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, & + & 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, & + & 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 (nint(slifcs(i)) /= nint(slianl(i))) then + if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 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 (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 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 (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 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 == 0) then + if (kount1 > 0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2 > 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 == 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) == aicice .and. slmask(i) == 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 + use sfccyc_module , only : num_threads + implicit none + integer, intent(in) :: len, mode, me + real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, & + & fldlmx,fldlmn,fldomx,fldjmn, & + & fldsmx,fldsmn,epsfld,percrit & + integer, parameter :: mmprt=2 +! + character(len=*) ttl + logical iceflg(len) + real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo + logical lgchek +! + logical first + real (kind=kind_io8) permax, per + data first /.true./ + save first +! + integer :: len_thread_m, i1_t, i2_t, it, & + & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & + & ij,nprt,kmaxs,kmins,i + integer :: islimsk(len), iwk(len) +! + if (first) then + first = .false. + endif + do it=1,len + islimsk(it) = nint(slimsk(it)) + enddo +! +! check against land-sea mask and ice cover mask +! + if(me == 0) then + 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,islimsk,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 /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) < 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 == 1) then + do i=1,kminl + fld(iwk(i)) = fldlmn + enddo + endif + endif +! +! upper bound check over bare land +! + if (fldlmx /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) > 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 == 1) then + do i=1,kmaxl + fld(iwk(i)) = fldlmx + enddo + endif + endif +! +! lower bound check over snow covered land +! + if (fldsmn /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) < 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 == 1) then + do i=1,kmins + fld(iwk(i)) = fldsmn + enddo + endif + endif +! +! upper bound check over snow covered land +! + if (fldsmx /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) > 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 == 1) then + do i=1,kmaxs + fld(iwk(i)) = fldsmx + enddo + endif + endif +! +! lower bound check over open ocean +! + if (fldomn /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 0.0 .and. fld(i) < 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 == 1) then + do i=1,kmino + fld(iwk(i)) = fldomn + enddo + endif + endif +! +! upper bound check over open ocean +! + if (fldomx /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) ==.0 .and. fld(i) > 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 == 1) then + do i=1,kmaxo + fld(iwk(i)) = fldomx + enddo + endif + endif +! +! lower bound check over sea ice without snow +! + if (fldimn /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 2 .and. sno(i) <= 0.0 & + & .and. fld(i) < 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 == 1) then + do i=1,kmini + fld(iwk(i)) = fldimn + enddo + endif + endif +! +! upper bound check over sea ice without snow +! + if (fldimx /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & + & fld(i) > 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 == 1) then + do i=1,kmaxi + fld(iwk(i)) = fldimx + enddo + endif + endif +! +! lower bound check over sea ice with snow +! + if (fldjmn /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & + & fld(i) < 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 == 1) then + do i=1,kminj + fld(iwk(i)) = fldjmn + enddo + endif + endif +! +! upper bound check over sea ice with snow +! + if (fldjmx /= 999.0) then + do i=i1_t,i2_t + if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & + & fld(i)> 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 == 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 == 0) then + permax = 0.0 + if(kminl > 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 > permax) permax = per + endif + if(kmaxl > 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 > 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 > 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 >.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 > 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 > 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 > 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 > permax) permax=per + endif + if(kminj > 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 > 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 > 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), smcclm(len,lsoil) +! + if (me == 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. +! TG3 MODS BEGIN + if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116 + & .and. kpds4 == 128) then +! print*,'turn off setrmsk for tg3' + lmask = .false. + + elseif(kpds5 == kpdtsf) then +! TG3 MODS END +! +! surface temperature +! + 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 == 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 +!! 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 + use sfccyc_module , only : num_threads + 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 + data first /.true./ + save first +! + integer len_thread_m, j1_t, j2_t, it +! + if (first) then + 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 + + end subroutine landtyp + +!>\ingroup mod_sfcsub + 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,slmskl,slmskw, & + & 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) slmskl(len), slmskw(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 > 0.0) then +!cbosu + if (me == 0) print*,'bosu fh gt 0' + + iy4 = iy + if (iy < 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 == 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 < dayhf(1)) rjday = rjday + 365. +! + if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m +! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if (mon2 == 13) mon2 = 1 + if (me == 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 == 2) mon = mon2 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, + & 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 < 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 < dayhf(1)) rjday = rjday + 365. + + if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday +! + if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m +! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if (mon2 == 13) mon2 = 1 + if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m +! +! for seasonal mean climatology +! + monend = 4 + is = im/3 + 1 + if (is == 5) is = 1 + do mm=1,monend + mmm = mm*3 - 2 + mmp = (mm+1)*3 - 2 + if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1s +! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) + if (sea2 == 13) sea2 = 1 + if (me == 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 == 3) is = 1 + do mm=1,monend + mmm = mm*6 - 5 + mmp = (mm+1)*6 - 5 + if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1y +! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) + if (hyr2 == 13) hyr2 = 1 + if (me == 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 .or. ialb == 2) then +!cbosu still need facsf and facwf. read them from the production file + if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl + &, 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,slmskl + &, alf,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif + do i = 1, len + if(slmskl(i) == 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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 == 5) is1 = 1 + if (is2 == 5) is2 = 1 + do nn=1,2 +! +! seasonal mean climatology + if(nn == 1) then + isx = is1 + else + isx = is2 + endif + if(isx == 1) kpd9 = 12 + if(isx == 2) kpd9 = 3 + if(isx == 3) kpd9 = 6 + if(isx == 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,slmskl, + & 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 .or. ialb == 2) then + if ( index(fnalbc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, + & 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,slmskw, + & 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,slmskw, +! & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskw, + & 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,slmskw, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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 == 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,slmskw, + & 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 == 5) isx = 1 + if (isx == 1) kpd9 = 12 + if (isx == 2) kpd9 = 3 + if (isx == 3) kpd9 = 6 + if (isx == 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,slmskl + &, 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 .or. ialb == 2) 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,slmskl, + & 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,slmskw, + & 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,slmskl, + & 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,slmskl, + & 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,slmskw, + & 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,slmskw, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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,slmskl, + & 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 .or. ialb == 2) 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 +!! 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 & + &, jj,w3kindreal,w3kindint + real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto +! +! + 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/gcycle.F90 b/physics/gcycle.F90 index 335e8f726..d85093c09 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,26 +15,26 @@ module gcycle_mod !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & xlat_d, xlon_d, slmsk, imap, jmap) ! ! - use machine, only: kind_phys + use machine, only: kind_phys, kind_io8 implicit none - integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & + integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & tile_num, nlunit, lsoil, lsoil_lsm, kice integer, intent(in) :: idate(:), ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind=kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), & - min_seaice, min_lakeice, & + real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:),& + min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind=kind_phys), intent(inout) :: smc(:,:), & slc(:,:), & @@ -81,7 +81,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & ! Local variables ! --------------- real(kind=kind_phys) :: & - SLMASK (nx*ny), & + slmskl (nx*ny), & + slmskw (nx*ny), & TSFFCS (nx*ny), & ZORFCS (nx*ny), & AISFCS (nx*ny), & @@ -92,7 +93,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1 (nx*ny*max(lsoil,lsoil_lsm)) - logical :: lake(nx*ny) + real (kind=kind_io8) :: min_ice(nx*ny) character(len=6) :: tile_num_ch real(kind=kind_phys) :: sig1t, dt_warm integer :: npts, nb, ix, jx, ls, ios, ll @@ -116,31 +117,55 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & if ( nsst > 0 ) then TSFFCS = tref else - TSFFCS = tsfc + TSFFCS = tsfco end if ! do ix=1,npts - ZORFCS(ix) = zorll (ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorli (ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorlo (ix) + if (landfrac(ix) > -1.0e-6_kind_phys) then + slmskl(ix) = ceiling(landfrac(ix)) + slmskw(ix) = floor(landfrac(ix)+1.0e-6_kind_phys) endif - ! DH* Why not 1.9 as for ZORFCS? - IF (slmsk(ix) > 1.99_kind_phys) THEN + +! IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN +! slmskl(ix) = 0.0_kind_phys +! slmskw(ix) = 0.0_kind_phys +! if (frac_grid) then +! slmskw(ix) = floor(landfrac(ix)) +! endif +! ELSE +! slmskl(ix) = 1.0_kind_phys +! slmskw(ix) = 1.0_kind_phys +! ENDIF + + if (lakefrac(ix) > 0.0_kind_phys) then + min_ice(ix) = min_lakeice + else + min_ice(ix) = min_seaice + endif + + zorfcs(ix) = zorll (ix) + if (nint(slmskl(ix)) /= 1 ) then + if (fice(ix) >= min_ice(ix)) then + zorfcs(ix) = zorli(ix) + else + zorfcs(ix) = zorlo(ix) + endif + endif + + IF (fice(ix) >= min_ice(ix)) THEN AISFCS(ix) = 1.0_kind_phys ELSE AISFCS(ix) = 0.0_kind_phys ENDIF - ! +! ALFFC1(ix ) = facsf(ix) ALFFC1(ix + npts ) = facwf(ix) - ! +! ALBFC1(ix ) = alvsf(ix) ALBFC1(ix + npts ) = alvwf(ix) ALBFC1(ix + npts*2) = alnsf(ix) ALBFC1(ix + npts*3) = alnwf(ix) - ! +! do ls = 1,max(lsoil,lsoil_lsm) ll = ix + (ls-1)*npts if (lsoil == lsoil_lsm) then @@ -153,19 +178,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1(ll) = sh2o(ix,ls) endif enddo - ! - IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN - SLMASK(ix) = 0.0_kind_phys - ELSE - SLMASK(ix) = 1.0_kind_phys - ENDIF - ! - if (lakefrac(ix) > 0.0_kind_phys) then - lake(ix) = .true. - else - lake(ix) = .false. - endif - end do + enddo ! #ifndef INTERNAL_FILE_NML inquire (file=trim(Model%fn_nml),exist=exists) @@ -179,7 +192,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & #endif CALL SFCCYCLE (9998, npts, max(lsoil,lsoil_lsm), sig1t, fhcyc, & idate(4), idate(2), idate(3), idate(1), & - phour, xlat_d, xlon_d, slmask, & + phour, xlat_d, xlon_d, slmskl, slmskw, & oro, oro_uf, use_ufo, nst_anl, & hice, fice, tisfc, snowd, slcfc1, & shdmin, shdmax, slope, snoalb, tsffcs, & @@ -188,8 +201,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & vfrac, vtype, stype, alffc1, cv, & cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & - lake, min_lakeice, min_seaice, & - ialb, isot, ivegsrc, & + min_ice, ialb, isot, ivegsrc, & trim(tile_num_ch), imap, jmap) #ifndef INTERNAL_FILE_NML close (Model%nlunit) @@ -198,26 +210,36 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & if ( nsst > 0 ) then tref = TSFFCS else - tsfc = TSFFCS +! tsfc = TSFFCS tsfco = TSFFCS endif ! do ix=1,npts zorll(ix) = ZORFCS(ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - zorli(ix) = ZORFCS(ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - zorlo(ix) = ZORFCS(ix) + if (.not. frac_grid) then + if (slmsk(ix) > 1.9_kind_phys) then + zorli(ix) = ZORFCS(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + zorlo(ix) = ZORFCS(ix) + endif + else + if (nint(slmskw(ix)) == 0 .and. nint(slmskl(ix)) /= 1) then + if (fice(ix) >= min_ice(ix)) then + zorli(ix) = ZORFCS(ix) + else + zorlo(ix) = ZORFCS(ix) + endif + endif endif - ! +! facsf(ix) = ALFFC1(ix ) facwf(ix) = ALFFC1(ix + npts ) - ! +! alvsf(ix) = ALBFC1(ix ) alvwf(ix) = ALBFC1(ix + npts ) alnsf(ix) = ALBFC1(ix + npts*2) alnwf(ix) = ALBFC1(ix + npts*3) - ! +! do ls = 1,max(lsoil,lsoil_lsm) ll = ix + (ls-1)*npts if(lsoil == lsoil_lsm) then @@ -226,10 +248,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & slc(ix,ls) = SLCFC1(ll) else smois(ix,ls) = SMCFC1(ll) - tslb(ix,ls) = STCFC1(ll) - sh2o(ix,ls) = SLCFC1(ll) + tslb(ix,ls) = STCFC1(ll) + sh2o(ix,ls) = SLCFC1(ll) endif - if (ls<=kice) tiice(ix,ls) = STCFC1(ll) + if (ls <= kice) tiice(ix,ls) = STCFC1(ll) enddo enddo ! diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 305e7a805..24aeaf216 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -44,7 +44,7 @@ subroutine sfc_sice_run & & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, lprnt, ipr, & + & flag_iter, lprnt, ipr, me, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & & islmsk_cice, & @@ -150,7 +150,7 @@ subroutine sfc_sice_run & real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys ! --- inputs: - integer, intent(in) :: im, kice, ipr + integer, intent(in) :: im, kice, ipr, me logical, intent(in) :: lprnt real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & @@ -363,14 +363,14 @@ subroutine sfc_sice_run & if (flag(i)) then if (tice(i) < timin) then print *,'warning: snow/ice temperature is too low:',tice(i) - &, ' i=',i + &, ' i=',i,' me=',me tice(i) = timin print *,'fix snow/ice temperature: reset it to:',tice(i) endif if (stsice(i,1) < timin) then print *,'warning: layer 1 ice temp is too low:',stsice(i,1) - &, ' i=',i + &, ' i=',i,' me=',me stsice(i,1) = timin print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) endif @@ -671,8 +671,8 @@ subroutine ice3lay snowd (i) = snowd(i) - snowmt(i) else snowmt(i) = snowd(i) - h1 = h1 - (tmelt - snowd(i)*dsli) & - & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1))) + h1 = max(zero, h1 - (tmelt - snowd(i)*dsli) & + & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1)))) snowd(i) = zero endif @@ -687,6 +687,7 @@ subroutine ice3lay else h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) endif + h2 = max(h2, zero) !> - If ice remains, even up 2 layers, else, pass negative energy back in snow. !! Calculate the new upper layer temperature (see \a eq.(38)). diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 469a967fc..2d3643160 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -281,6 +281,14 @@ type = integer intent = in optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F [hice] standard_name = sea_ice_thickness long_name = sea-ice thickness diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 3356a8982..442b94681 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -8,6 +8,7 @@ !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). module sfccyc_module + use machine , only : kind_io8,kind_io4 implicit none save ! @@ -32,6 +33,7 @@ module sfccyc_module integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) integer, parameter :: kpdalf(2)=(/214,217/) ! + real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice @@ -71,18 +73,18 @@ end module sfccyc_module !!\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,nthrds,nlunit & - &, sz_nml,input_nml_file & - &, lake, min_lakeice, min_seaice & + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh,rla,rlo & + &, slmskl,slmskw,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,nthrds,nlunit & + &, sz_nml,input_nml_file & + &, min_ice & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 @@ -92,8 +94,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer, intent(in) :: i_index(len), j_index(len), & & me, nthrds logical, intent(in) :: use_ufo, nst_anl - logical, intent(in) :: lake(len) - real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice + real (kind=kind_io8), intent(in) :: min_ice(len) real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & & orolmx,orolmn,oroomx,oroomn,orosmx, & @@ -399,7 +400,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! parameter(snwmin=25.,snwmax=100.) parameter(snwmin=5.0,snwmax=100.) - real (kind=kind_io8), parameter :: ten=10.0, one=1.0 +! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 + real (kind=kind_io8), parameter :: crit_lnd=1.0e-6, & + & crit_wat=1.0e-6 ! ! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) @@ -451,9 +454,9 @@ 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) & - &, orogd(len) - real (kind=kind_io8) rla(len), rlo(len) + real (kind=kind_io8) slmskl(len), slmskw(len) + real (kind=kind_io8) orog(len), orog_uf(len), orogd(len) + real (kind=kind_io8) rla(len), rlo(len) ! ! permanent/extremes ! @@ -784,19 +787,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & num_threads = nthrds ! 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 +! tem1 = abs(rla(i) + 66.35) +! tem2 = abs(rlo(i) - 109.01) +! if(tem1 < 0.10 .and. tem2 < 0.10) 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 @@ -1055,12 +1058,38 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & allocate (glacir(len)) allocate (amxice(len)) ! +! do i=1,len +! if (landfrac(i) > crit_lnd) then +! slmskl(i) = one +! slmskw(i) = one +! if (one-landfrac(i) > crit_wat) then +! slmskw(i) = zero +! if (sicfcs(i) > min_ice(i)) then +! slmskw(i) = 2.0_kind_io8 +! endif +! endif +! else +! slmskl(i) = zero +! slmskw(i) = zero +! if (sicfcs(i) > min_ice(i)) then +! slmskl(i) = 2.0_kind_io8 +! slmskw(i) = 2.0_kind_io8 +! endif +! endif +! if (i == 1) write(0,*)' landfrac=',landfrac(i),' slmskl=', & +! if (i == 1) write(0,*)' slmskl=', slmskl(i),' slmskw=', & +! & slmskw(i),' sicfcs=',sicfcs(i) +! enddo + +! write(1000+me,*)' slmskl=',slmskl +! write(1000+me,*)' slmskw=',slmskw +! ! read glacier ! kpd9 = -1 kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, - & glacir,len,iret + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl + &, glacir,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1069,8 +1098,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! read maximum ice extent ! kpd7 = -1 - call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, - & amxice,len,iret + call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmskl + &, amxice,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1103,7 +1132,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! percrit=critp1 ! - call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & fnvetc,fnsotc, @@ -1120,6 +1149,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & 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 @@ -1142,11 +1172,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albclm,slmask,albomx,len) + call albocn(albclm,slmskl,albomx,len) ! ! make sure vegetation type and soil type are non zero over land ! - call landtyp(vetclm,sotclm,slpclm,slmask,len) + call landtyp(vetclm,sotclm,slpclm,slmskl,len) ! !cwu [-1l/+1l] !* ice concentration or ice mask (only ice mask used in the model now) @@ -1157,7 +1187,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i) /= 1.0) then sicclm(i) = sicimx sihfcs(i) = glacir_hice @@ -1166,21 +1196,21 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & crit=aislim !* crit=0.5 ! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisclm, len, 'ge', min_ice) elseif(fnacnc(1:8) /= ' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo ! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnclm, len, 'ge', min_ice) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1188,15 +1218,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of sea ice mask ! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisclm,len,aicice,sliclm) + call setlsi(slmskw,aisclm,len,aicice,sliclm) ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmask=',slmask(iprnt) +! *,sliclm(iprnt),' slmskw=',slmskw(iprnt) ! ! write(6,*) 'sliclm' ! znnt=1. @@ -1204,7 +1234,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of snow ! - call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) + call qcsnow(snoclm,slmskl,aisclm,glacir,len,snosmx,landice,me) ! call setzro(snoclm,epssno,len) ! @@ -1425,7 +1455,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read analysis fields ! - call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & fnveta,fnsota, @@ -1445,6 +1475,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, 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 @@ -1476,7 +1507,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (use_ufo .and. .not. nst_anl) then ztsfc = 0.0 - call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog_uf,slmskw,ztsfc,len,rlapse) endif ! ! ice concentration or ice mask (only ice mask used in the model now) @@ -1486,7 +1517,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1495,13 +1526,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! crit=aislim !* crit=0.5 ! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisanl, len, 'ge', min_ice) elseif(fnacna(1:8) /= ' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1509,20 +1540,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo ! crit=aislim do i=1,len - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif + crit = min_ice(i) if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then - slianl(i) = 2. + slianl(i) = 2.0_kind_io8 ! print *,'cycle - new ice form: fice=',sicanl(i) elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then slianl(i) = 0. ! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i) = 0. + elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then + if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid + slianl(i) = 2.0_kind_io8 + else +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i) = 0.0_kind_io8 + endif endif enddo ! znnt=10. @@ -1534,22 +1565,22 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) ! call rof01(acnanl,len,'ge',aislim) - call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnanl, len, 'ge', min_ice) do i=1,len aisanl(i) = acnanl(i) enddo endif ! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmask=',slmask(iprnt) +! &,glacir(iprnt),' slmskw=',slmskw(iprnt) ! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisanl,len,aicice,slianl) + call setlsi(slmskw,aisanl,len,aicice,slianl) ! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmask=',slmask(iprnt) +! *,slianl(iprnt),' slmskw=',slmskw(iprnt) ! ! do k=1,lsoil @@ -1576,14 +1607,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albanl,slmask,albomx,len) + call albocn(albanl,slmskl,albomx,len) ! ! quality control of snow and sea-ice ! process snow depth or snow cover ! if (fnsnoa(1:8) /= ' ') then call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) + call qcsnow(snoanl,slmskl,aisanl,glacir,len,ten,landice,me) if (.not.landice) then call snodpth2(glacir,snosmx,snoanl, len, me) endif @@ -1601,14 +1632,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & else crit = 0.5 call rof01(scvanl,len,'ge',crit) - call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) + call qcsnow(scvanl,slmskl,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 qcsnow(scvanl,slmskl,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, @@ -1814,13 +1845,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1.0 - call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tg3fcs,orogd,slmskl,ztsfc,len,-rlapse) endif ztsfc = 0. - call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse) else ztsfc = 0. - call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orog,slmskw,ztsfc,len,-rlapse) endif !clu [+12l] -------------------------------------------------------------- @@ -1840,7 +1871,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmask,albomx,len) + call albocn(albfcs,slmskl,albomx,len) do i=1,len icefl2(i) = sicfcs(i) .gt. 0.99999 enddo @@ -1983,6 +2014,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) + do i=1,len + if (sicanl(i) >= min_ice(i)) then + slianl(i) = 2.0_kind_io8 + else + slianl(i) = zero + sicanl(i) = zero + endif + enddo + if (fh-deltsfc > -0.001 ) then do i=1,len if(slianl(i) == 0.0) then @@ -2011,8 +2051,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! merge analysis and forecast. note tg3, ais are not merged ! +! if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:) + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, + & slmskl,slmskw,sihfcs,sicfcs, & vmnfcs,vmxfcs,slpfcs,absfcs, & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & cvfcs ,cvbfcs,cvtfcs, @@ -2039,6 +2082,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) ! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) +! if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlmer=',stcanl(iprnt,:) ! ! new ice/melted ice @@ -2055,6 +2100,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) ! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) +! if(lprnt) print *,' stcan=',stcanl(iprnt,:) ! ! set tsfc to tsnow over snow ! @@ -2165,13 +2211,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1. - call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tg3anl,orogd,slmskl,ztsfc,len,rlapse) endif ztsfc = 0. - call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse) else ztsfc = 0. - call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse) endif ! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) ! @@ -2344,6 +2390,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif enddo enddo +! if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', & +! & slifcs(iprnt) do j = 1,4 do i = 1,len albfcs(i,j) = albanl(i,j) @@ -2358,27 +2406,31 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !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 (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (slifcs(i) >= 1.99_kind_io8) then - if (sicfcs(i) > crit) then - tem1 = 1.0_kind_io8 / sicfcs(i) - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem1 - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 - sicfcs(i) = sicanl(i) + if (slmskw(i) == zero) then + crit = min_ice(i) + if (sicanl(i) >= crit) then + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (sicfcs(i) >= crit) then + tem1 = 1.0_kind_io8 / sicfcs(i) + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) + else + tsffcs(i) = tgice + sitfcs(i) = tgice + sicfcs(i) = sicanl(i) + sihfcs(i) = sihnew + endif +! if (lprnt .and. i == iprnt) write(0,*)' sicanl=',sicanl(i), & +! &' sicfcs=',sicfcs(i),' siccanl=',sicanl(i),' sihfcs=',sihfcs(i) else tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice -! sihfcs(i) = sihnew sihfcs(i) = 0.0_kind_io8 sicfcs(i) = 0.0_kind_io8 slifcs(i) = 0.0_kind_io8 + sitfcs(i) = tsffcs(i) endif endif if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then @@ -2393,11 +2445,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! sicfcs(i) = 0.0_kind_io8 ! sitfcs(i) = tsffcs(i) ! else -! if (lake(i)) then -! crit = min_lakeice -! else -! crit = min_seaice -! endif +! crit = min_ice(i) ! if (sicfcs(i) < crit) then ! print *,'warning: check, slifcs and sicfcs', & ! & slifcs(i),sicfcs(i) @@ -2487,6 +2535,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & end if ! ! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) +! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:) return end subroutine sfccycle @@ -3335,8 +3384,10 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& !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.' + print*,'no matching mask found ',i,i1,j1,ix,jx & + &, ' slmask=',slmask(i),' me=',me & + &, ' outlon=',outlon(i),' outlat=',outlat(i) + &, 'set to default value.' endif gauout(i) = 0.0 @@ -3660,8 +3711,8 @@ 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,& + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & + & 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 @@ -3691,7 +3742,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & &, 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) slmskl(len), slmskw(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) integer kpdalb(4), kpdalf(2) @@ -3721,7 +3772,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irttsf = 1 if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,fh,tsfanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3748,7 +3799,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf0 ! if(fntsfa(1:8).ne.' ' .and. lanom) then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,0.,tsfan0,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3774,7 +3825,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalb = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 4 - call fixrda(lugb,fnalba,kpdalb(kk),slmask, + call fixrda(lugb,fnalba,kpdalb(kk),slmskl, & iy,im,id,ih,fh,albanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3805,7 +3856,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalf = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 2 - call fixrda(lugb,fnalba,kpdalf(kk),slmask, + call fixrda(lugb,fnalba,kpdalf(kk),slmskl, & iy,im,id,ih,fh,alfanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3836,7 +3887,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtwet=0 irtsmc=0 if(fnweta(1:8).ne.' ') then - call fixrda(lugb,fnweta,kpdwet,slmask, + call fixrda(lugb,fnweta,kpdwet,slmskl, & iy,im,id,ih,fh,wetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3854,11 +3905,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'bucket wetness analysis provided.' endif elseif(fnsmca(1:8).ne.' ') then - call fixrda(lugb,fnsmca,kpdsmc,slmask, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & 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, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & iy,im,id,ih,fh,smcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3917,14 +3968,14 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & call abort endif if (kgds(1) == 4) then ! gaussian data is depth - call fixrda(lugb,fnsnoa,kpdsnd,slmask, + call fixrda(lugb,fnsnoa,kpdsnd,slmskl, & 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 + 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, + call fixrda(lugb,fnsnoa,kpdsno,slmskl, & iy,im,id,ih,fh,snoanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3946,9 +3997,9 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtsno=0 elseif(fnscva(1:8).ne.' ') then do i=1,len - snoanl(i)=0. + snoanl(i) = 0. enddo - call fixrda(lugb,fnscva,kpdscv,slmask, + call fixrda(lugb,fnscva,kpdscv,slmskl, & iy,im,id,ih,fh,scvanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3977,7 +4028,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtacn=0 irtais=0 if(fnacna(1:8).ne.' ') then - call fixrda(lugb,fnacna,kpdacn,slmask, + call fixrda(lugb,fnacna,kpdacn,slmskw, & iy,im,id,ih,fh,acnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3996,7 +4047,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'ice concentration analysis provided.' endif elseif(fnaisa(1:8).ne.' ') then - call fixrda(lugb,fnaisa,kpdais,slmask, + call fixrda(lugb,fnaisa,kpdais,slmskw, & iy,im,id,ih,fh,aisanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4024,7 +4075,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtzor=0 if(fnzora(1:8).ne.' ') then - call fixrda(lugb,fnzora,kpdzor,slmask, + call fixrda(lugb,fnzora,kpdzor,slmskl, & iy,im,id,ih,fh,zoranl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4053,7 +4104,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irttg3=0 irtstc=0 if(fntg3a(1:8).ne.' ') then - call fixrda(lugb,fntg3a,kpdtg3,slmask, + call fixrda(lugb,fntg3a,kpdtg3,slmskl, & iy,im,id,ih,fh,tg3anl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4072,11 +4123,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'deep soil tmp analysis provided.' endif elseif(fnstca(1:8).ne.' ') then - call fixrda(lugb,fnstca,kpdstc,slmask, + call fixrda(lugb,fnstca,kpdstc,slmskl, & 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, + call fixrda(lugb,fnstca,kpdstc,slmskl, & iy,im,id,ih,fh,stcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4105,7 +4156,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtveg=0 if(fnvega(1:8).ne.' ') then - call fixrda(lugb,fnvega,kpdveg,slmask, + call fixrda(lugb,fnvega,kpdveg,slmskl, & iy,im,id,ih,fh,veganl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4134,7 +4185,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvet=0 if(fnveta(1:8).ne.' ') then - call fixrda(lugb,fnveta,kpdvet,slmask, + call fixrda(lugb,fnveta,kpdvet,slmskl, & iy,im,id,ih,fh,vetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4163,7 +4214,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtsot=0 if(fnsota(1:8).ne.' ') then - call fixrda(lugb,fnsota,kpdsot,slmask, + call fixrda(lugb,fnsota,kpdsot,slmskl, & iy,im,id,ih,fh,sotanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4194,7 +4245,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmn=0 if(fnvmna(1:8).ne.' ') then - call fixrda(lugb,fnvmna,kpdvmn,slmask, + call fixrda(lugb,fnvmna,kpdvmn,slmskl, & iy,im,id,ih,fh,vmnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4224,7 +4275,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmx=0 if(fnvmxa(1:8).ne.' ') then - call fixrda(lugb,fnvmxa,kpdvmx,slmask, + call fixrda(lugb,fnvmxa,kpdvmx,slmskl, & iy,im,id,ih,fh,vmxanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4254,7 +4305,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtslp=0 if(fnslpa(1:8).ne.' ') then - call fixrda(lugb,fnslpa,kpdslp,slmask, + call fixrda(lugb,fnslpa,kpdslp,slmskl, & iy,im,id,ih,fh,slpanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4284,7 +4335,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtabs=0 if(fnabsa(1:8).ne.' ') then - call fixrda(lugb,fnabsa,kpdabs,slmask, + call fixrda(lugb,fnabsa,kpdabs,slmskl, & iy,im,id,ih,fh,absanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4479,21 +4530,14 @@ subroutine rof01(aisfld, len, op, crit) end !>\ingroup mod_sfcsub - subroutine rof01_len(aisfld, len, op, lake, critl, crits) + subroutine rof01_len(aisfld, len, op, crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len - logical :: lake(len) - real (kind=kind_io8) aisfld(len), critl, crits, crit(len) + real (kind=kind_io8), intent(in) :: crit(len) + real (kind=kind_io8) aisfld(len) character*2 op ! - do i=1,len - if (lake(i)) then - crit(i) = critl - else - crit(i) = crits - endif - enddo if(op == 'ge') then do i=1,len if(aisfld(i) >= crit(i)) then @@ -4610,7 +4654,7 @@ end subroutine snodpth !>\ingroup mod_sfcsub !! This subroutine merges analysis and forecast. subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & - & sihfcs,sicfcs, & + & slmskl,slmskw,sihfcs,sicfcs, & & vmnfcs,vmxfcs,slpfcs,absfcs, & & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & & cvfcs ,cvbfcs,cvtfcs, & @@ -4634,7 +4678,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice, & - & num_threads + & num_threads, zero, one implicit none integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & @@ -4659,6 +4703,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! + real (kind=kind_io8) slmskl(len), slmskw(len) real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & & zorfcs(len), albfcs(len,4), aisfcs(len), & & cvfcs (len), cvbfcs(len), cvtfcs(len), & @@ -4922,7 +4967,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & 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 + if(slianl(i) == zero) then vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots else @@ -4940,7 +4985,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & i2_t = min(i1_t+len_thread_m-1,len) ! do i=i1_t,i2_t - if(slianl(i).eq.0.) then + if(slianl(i) == zero) then +! if(slmskw(i) == zero) then !.... tsffc2 is the previous anomaly + today's climatology ! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) ! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs @@ -4958,7 +5004,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & 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 + endif + if(slmskl(i) == one .or. slianl(i) > zero) then tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl ! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl @@ -5061,11 +5108,11 @@ end subroutine merge !>\ingroup mod_sfcsub 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) + & 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 @@ -5089,8 +5136,8 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & 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 + if (nint(slifcs(i)) /= nint(slianl(i))) then + if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 1) then print *,'inconsistency in slifcs or slianl' print 910,rla(i),rlo(i),slifcs(i),slianl(i), & tsffcs(i),tsfanl(i) @@ -5101,7 +5148,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interpolated climatology indicates melted sea ice ! - if(slianl(i).eq.0..and.slifcs(i).eq.2.) then + if (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 2) then tsfanl(i) = tsfmin albanl(i,1) = albsea albanl(i,2) = albsea @@ -5122,7 +5169,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interplated climatoloyg/analysis indicates new sea ice ! - if(slianl(i).eq.2..and.slifcs(i).eq.0.) then + if (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 0) then tsfanl(i) = tsfice albanl(i,1) = albice albanl(i,2) = albice @@ -5142,15 +5189,15 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & 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 + if (me == 0) then + if (kount1 > 0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2 > 0) then + write(6,*) 'sea ice formed. tsf,alb,zor are filled', + & ' at ',kount2,' points' + endif endif ! return @@ -6882,8 +6929,8 @@ 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,& + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & & fnvetc,fnsotc, & & fnvmnc,fnvmxc,fnslpc,fnabsc, & @@ -6933,7 +6980,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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) slmskl(len), slmskw(len), tsfcl0(len) real (kind=kind_io8), allocatable :: slmask_noice(:) ! logical lanom, gaus, first @@ -7105,7 +7152,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & do nn=1,2 mon = mon1 if (nn == 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7247,7 +7294,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 1 .or. ialb == 2) then !cbosu still need facsf and facwf. read them from the production file if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7256,13 +7303,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & & kpdalf(1), alf(:,1), 1, len, me) endif else - call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) endif do i = 1, len - if(slmask(i).eq.1.) then + if(slmskl(i) == 1.) then alf(i,2) = 100. - alf(i,1) endif enddo @@ -7272,7 +7319,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmskl, & tg3,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7290,7 +7337,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmskl, & vet,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7315,7 +7362,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmskl, & sot,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7332,7 +7379,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmskl, & vmn,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7349,7 +7396,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmskl, & vmx,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7365,7 +7412,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmskl, & slp,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7381,7 +7428,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmskl, & absm,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7395,20 +7442,20 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! is1 = sea1/3 + 1 is2 = sea2/3 + 1 - if (is1 .eq. 5) is1 = 1 - if (is2 .eq. 5) is2 = 1 + if (is1 == 5) is1 = 1 + if (is2 == 5) is2 = 1 do nn=1,2 ! ! seasonal mean climatology - if(nn.eq.1) then - isx=is1 + if(nn == 1) then + isx = is1 else - isx=is2 + 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 + if(isx == 1) kpd9 = 12 + if(isx == 2) kpd9 = 3 + if(isx == 3) kpd9 = 6 + if(isx == 4) kpd9 = 9 ! ! seasonal mean climatology ! @@ -7420,7 +7467,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7437,7 +7484,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7455,7 +7502,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7465,7 +7512,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! fh2 = fh - deltsfc ! if (fh2 .gt. 0.0) then -! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, +! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmskw, ! & iy,im,id,ih,fh2,tsfcl2,len,iret ! &, imsk, jmsk, slmskh, gaus,blno, blto ! &, outlat, outlon, me) @@ -7479,14 +7526,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & 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, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7499,7 +7546,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! 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 + slmask_noice = 1.0 do i = 1, len if (nint(vet(i)) < 1 .or. & nint(vet(i)) == landice_cat) then @@ -7527,7 +7574,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnstcc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, + call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmskl, & stc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7542,12 +7589,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7=-1 if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & 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, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7559,7 +7606,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7568,7 +7615,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7587,7 +7634,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7607,7 +7654,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7656,7 +7703,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & k1 = mod(k2,2) + 1 mon = mon1s kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,k1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7696,7 +7743,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl &, alb(1,k,m2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7723,7 +7770,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7 = -1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7739,7 +7786,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7 = -1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7748,14 +7795,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & 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, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7796,12 +7843,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7 = -1 if (fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & 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, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7813,7 +7860,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7822,7 +7869,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7841,7 +7888,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7852,7 +7899,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & 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, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) From 71a63eb16e5277702e5c779034dfd81a6aa188b8 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 28 Apr 2021 02:57:59 +0000 Subject: [PATCH 041/165] Define logical flag 'cplgocart' for coupling with GOCART component. --- physics/GFS_surface_generic.meta | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 47b685f72..4f9cca33c 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -497,6 +497,14 @@ type = logical intent = in optional = F +[cplgocart] + standard_name = flag_for_gocart_coupling + long_name = flag controlling gocart collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F [cplwav] standard_name = flag_for_wave_coupling long_name = flag controlling cplwav collection (default off) From 8e8df6a1ba924ebbb6759bda30d0643b1b986b3e Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 28 Apr 2021 03:03:16 +0000 Subject: [PATCH 042/165] Fill 10-meter wind coupling arrays if coupling to GOCART. --- physics/GFS_surface_generic.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 483eccdf8..ecb0e82fb 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -209,7 +209,7 @@ end subroutine GFS_surface_generic_post_finalize !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& + subroutine GFS_surface_generic_post_run (im, cplflx, cplgocart, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & @@ -221,7 +221,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt implicit none integer, intent(in) :: im - logical, intent(in) :: cplflx, cplwav, lssav + logical, intent(in) :: cplflx, cplgocart, cplwav, lssav logical, dimension(im), intent(in) :: icy, wet real(kind=kind_phys), intent(in) :: dtf @@ -274,7 +274,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt v1(i) = vgrs_1(i) enddo - if (cplflx .or. cplwav) then + if (cplflx .or. cplgocart .or. cplwav) then do i=1,im u10mi_cpl(i) = u10m(i) v10mi_cpl(i) = v10m(i) From df750fe095e3c9a673b9d118f0d04b1e3640456b Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Wed, 28 Apr 2021 03:07:50 +0000 Subject: [PATCH 043/165] Provide proper upward sensible heat flux over the ocean when coupling with aerosol component if available (cplflx=.true.). --- physics/GFS_PBL_generic.F90 | 30 ++++++++++++++++++++---------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 026e91416..a96ba1f8e 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -533,16 +533,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, endif ! nvdiff == ntrac - if (cplchm) then - do i = 1, im - tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) - ushfsfci(i) = -cp * tem * hflx(i) ! upward sensible heat flux - enddo - ! dkt_cpl has dimensions (1:im,1:levs), but dkt has (1:im,1:levs-1) - dkt_cpl(1:im,1:levs-1) = dkt(1:im,1:levs-1) - endif - - ! --- ... coupling insertion if (cplflx) then @@ -594,6 +584,26 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, enddo endif + if (cplchm) then + if (cplflx) then + do i = 1, im + if (oceanfrac(i) > zero) then + ushfsfci(i) = dtsfci_cpl(i) + else + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + ushfsfci(i) = cp * rho * hflx(i) + end if + end do + else + do i = 1, im + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + ushfsfci(i) = cp * rho * hflx(i) + end do + end if + ! dkt_cpl has dimensions (1:im,1:levs), but dkt has (1:im,1:levs-1) + dkt_cpl(1:im,1:levs-1) = dkt(1:im,1:levs-1) + end if + !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im From c54012c35635f40898117111e82f50a41a754a2e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 29 Apr 2021 09:56:13 -0400 Subject: [PATCH 044/165] some additional updates in cycling codes --- physics/gcycle.F90 | 16 ++----------- physics/sfcsub.F | 59 ++++++++++++---------------------------------- 2 files changed, 17 insertions(+), 58 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index d85093c09..172ca60fb 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -118,7 +118,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, TSFFCS = tref else TSFFCS = tsfco - end if + endif ! do ix=1,npts if (landfrac(ix) > -1.0e-6_kind_phys) then @@ -126,17 +126,6 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slmskw(ix) = floor(landfrac(ix)+1.0e-6_kind_phys) endif -! IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN -! slmskl(ix) = 0.0_kind_phys -! slmskw(ix) = 0.0_kind_phys -! if (frac_grid) then -! slmskw(ix) = floor(landfrac(ix)) -! endif -! ELSE -! slmskl(ix) = 1.0_kind_phys -! slmskw(ix) = 1.0_kind_phys -! ENDIF - if (lakefrac(ix) > 0.0_kind_phys) then min_ice(ix) = min_lakeice else @@ -210,7 +199,6 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, if ( nsst > 0 ) then tref = TSFFCS else -! tsfc = TSFFCS tsfco = TSFFCS endif ! @@ -251,7 +239,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, tslb(ix,ls) = STCFC1(ll) sh2o(ix,ls) = SLCFC1(ll) endif - if (ls <= kice) tiice(ix,ls) = STCFC1(ll) +! if (ls <= kice) tiice(ix,ls) = STCFC1(ll) enddo enddo ! diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 442b94681..bfee6b095 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -20,10 +20,10 @@ module sfccyc_module &, 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, +! & kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, + & kpdais=91, kpdtg3=11, kpdplr=224, + & kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, + & 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, @@ -401,8 +401,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! parameter(snwmin=25.,snwmax=100.) parameter(snwmin=5.0,snwmax=100.) ! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 - real (kind=kind_io8), parameter :: crit_lnd=1.0e-6, & - & crit_wat=1.0e-6 ! ! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) @@ -517,7 +515,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! 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) 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) @@ -865,14 +863,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif if (ivegsrc == 2) then ! sib - veg_type_landice=13 + veg_type_landice = 13 else - veg_type_landice=15 + veg_type_landice = 15 endif if (isot == 0) then - soil_type_landice=9 + soil_type_landice = 9 else - soil_type_landice=16 + soil_type_landice = 16 endif ! deltf = deltsfc / 24.0 @@ -1058,32 +1056,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & allocate (glacir(len)) allocate (amxice(len)) ! -! do i=1,len -! if (landfrac(i) > crit_lnd) then -! slmskl(i) = one -! slmskw(i) = one -! if (one-landfrac(i) > crit_wat) then -! slmskw(i) = zero -! if (sicfcs(i) > min_ice(i)) then -! slmskw(i) = 2.0_kind_io8 -! endif -! endif -! else -! slmskl(i) = zero -! slmskw(i) = zero -! if (sicfcs(i) > min_ice(i)) then -! slmskl(i) = 2.0_kind_io8 -! slmskw(i) = 2.0_kind_io8 -! endif -! endif -! if (i == 1) write(0,*)' landfrac=',landfrac(i),' slmskl=', & -! if (i == 1) write(0,*)' slmskl=', slmskl(i),' slmskw=', & -! & slmskw(i),' sicfcs=',sicfcs(i) -! enddo - -! write(1000+me,*)' slmskl=',slmskl -! write(1000+me,*)' slmskw=',slmskw -! ! read glacier ! kpd9 = -1 @@ -1579,6 +1551,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! set ocean/land/sea-ice mask ! call setlsi(slmskw,aisanl,len,aicice,slianl) + ! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' ! *,slianl(iprnt),' slmskw=',slmskw(iprnt) ! @@ -2423,13 +2396,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & sicfcs(i) = sicanl(i) sihfcs(i) = sihnew endif -! if (lprnt .and. i == iprnt) write(0,*)' sicanl=',sicanl(i), & -! &' sicfcs=',sicfcs(i),' siccanl=',sicanl(i),' sihfcs=',sihfcs(i) else tsffcs(i) = tsfanl(i) - sihfcs(i) = 0.0_kind_io8 - sicfcs(i) = 0.0_kind_io8 - slifcs(i) = 0.0_kind_io8 + sihfcs(i) = zero + sicfcs(i) = zero + slifcs(i) = zero sitfcs(i) = tsffcs(i) endif endif @@ -2532,7 +2503,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & tsffcs(i) = min(tsffcs(i),273.15) endif enddo - end if + endif ! ! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) ! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:) @@ -5938,7 +5909,7 @@ subroutine albocn(albclm,slmask,albomx,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 + if(slmask(i) == 0) then albclm(i,1) = albomx albclm(i,2) = albomx albclm(i,3) = albomx From 0f227e86c03ea777f49e0b718f96a35e4de57a07 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 29 Apr 2021 15:19:19 -0400 Subject: [PATCH 045/165] some minor fix in gcycle --- physics/gcycle.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 172ca60fb..9bba1546a 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -122,7 +122,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, ! do ix=1,npts if (landfrac(ix) > -1.0e-6_kind_phys) then - slmskl(ix) = ceiling(landfrac(ix)) + slmskl(ix) = ceiling(landfrac(ix)-1.0e-6_kind_phys) slmskw(ix) = floor(landfrac(ix)+1.0e-6_kind_phys) endif From 000a409698edd73debae29d96087df6188b52e9f Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Sat, 1 May 2021 04:39:31 +0000 Subject: [PATCH 046/165] Output model-specific debug information for quantities exported to the coupled aerosol component. --- physics/GFS_debug.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2d7f5616f..27a6f2724 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -807,8 +807,13 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, if (Model%cplchm) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%rainc_cpl', Coupling%rainc_cpl) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ushfsfci ', Coupling%ushfsfci ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dkt ', Coupling%dkt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqdti ', Coupling%dqdti ) + if (Model%cplgocart) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfi_lsan', Coupling%pfi_lsan ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfl_lsan', Coupling%pfl_lsan ) + else + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dkt ', Coupling%dkt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqdti ', Coupling%dqdti ) + endif end if if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sppt_wts', Coupling%sppt_wts) From 06a9b731b3c457cd88b8549cdfb4a2da4e6d03f0 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Sat, 1 May 2021 04:49:25 +0000 Subject: [PATCH 047/165] Update GFDL cloud microphysics to provide instantaneous 3D non-convective liquid and ice precipitation fluxes. --- physics/gfdl_cloud_microphys.F90 | 22 +++++++++++++++++++-- physics/gfdl_cloud_microphys.meta | 26 +++++++++++++++++++++++++ physics/module_gfdl_cloud_microphys.F90 | 12 +++++++++++- 3 files changed, 57 insertions(+), 3 deletions(-) diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index c41323ad5..b62905477 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -118,7 +118,8 @@ subroutine gfdl_cloud_microphys_run( & gt0, gu0, gv0, vvl, prsl, phii, del, & rain0, ice0, snow0, graupel0, prcp0, sr, & dtp, hydrostatic, phys_hydrostatic, lradar, refl_10cm, & - reset, effr_in, rew, rei, rer, res, reg, errmsg, errflg) + reset, effr_in, rew, rei, rer, res, reg, & + cplgocart, pfi_lsan, pfl_lsan, errmsg, errflg) use machine, only: kind_phys @@ -158,6 +159,9 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), intent(inout), dimension(1:im,1:levs) :: refl_10cm logical, intent (in) :: reset, effr_in real(kind=kind_phys), intent(inout), dimension(1:im,1:levs) :: rew, rei, rer, res, reg + logical, intent (in) :: cplgocart + ! ice and liquid water 3d precipitation fluxes - only allocated if cplgocart is .true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: pfi_lsan, pfl_lsan character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -168,6 +172,7 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), dimension(1:im,1:levs) :: delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qn1, qi1, & qs1, pt_dt, qa_dt, u_dt, v_dt, w, qv_dt, ql_dt, qr_dt, qi_dt, & qs_dt, qg_dt, p123, refl + real(kind=kind_phys), dimension(1:im,1,1:levs) :: pfils, pflls real(kind=kind_phys), dimension(:,:), allocatable :: den real(kind=kind_phys) :: onebg real(kind=kind_phys) :: tem @@ -202,6 +207,8 @@ subroutine gfdl_cloud_microphys_run( & u_dt(i,k) = 0.0 v_dt(i,k) = 0.0 qn1(i,k) = 0.0 + pfils(i,1,k) = 0.0 + pflls(i,1,k) = 0.0 ! flip vertical (k) coordinate qv1(i,k) = gq0(i,kk) ql1(i,k) = gq0_ntcw(i,kk) @@ -232,7 +239,7 @@ subroutine gfdl_cloud_microphys_run( & qv1, ql1, qr1, qi1, qs1, qg1, qa1, qn1, qv_dt, ql_dt, qr_dt, qi_dt, & qs_dt, qg_dt, qa_dt, pt_dt, pt, w, uin, vin, u_dt, v_dt, dz, delp, & garea, dtp, frland, rain0, snow0, ice0, graupel0, hydrostatic, & - phys_hydrostatic, p123, lradar, refl, reset) + phys_hydrostatic, p123, lradar, refl, reset, pfils, pflls) tem = dtp*con_p001/con_day ! fix negative values @@ -291,6 +298,17 @@ subroutine gfdl_cloud_microphys_run( & enddo enddo + ! output ice and liquid water 3d precipitation fluxes if requested + if (cplgocart) then + do k=1,levs + kk = levs-k+1 + do i=1,im + pfi_lsan(i,k) = pfils(i,1,kk) + pfl_lsan(i,k) = pflls(i,1,kk) + enddo + enddo + endif + if(effr_in) then allocate(den(1:im,1:levs)) do k=1,levs diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 961a3e33f..83095a34f 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -486,6 +486,32 @@ kind = kind_phys intent = inout optional = F +[cplgocart] + standard_name = flag_for_gocart_coupling + long_name = flag controlling gocart collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[pfi_lsan] + standard_name = ice_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of ice from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pfl_lsan] + standard_name = liquid_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of liquid water from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/module_gfdl_cloud_microphys.F90 index 1fa33fc18..7f00d9bca 100644 --- a/physics/module_gfdl_cloud_microphys.F90 +++ b/physics/module_gfdl_cloud_microphys.F90 @@ -361,7 +361,7 @@ subroutine gfdl_cloud_microphys_mod_driver ( qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & uin, vin, udt, vdt, dz, delp, area, dt_in, land, & rain, snow, ice, graupel, hydrostatic, phys_hydrostatic, & - p, lradar, refl_10cm,reset) + p, lradar, refl_10cm, reset, pfils, pflls) implicit none @@ -392,6 +392,7 @@ subroutine gfdl_cloud_microphys_mod_driver ( logical, intent (in) :: lradar real, intent (out), dimension (iis:iie, jjs:jje, kks:kke) :: refl_10cm logical, intent (in) :: reset + real, intent (out), dimension (iis:iie, jjs:jje, kks:kke) :: pfils, pflls ! Local variables logical :: melti = .false. @@ -483,6 +484,9 @@ subroutine gfdl_cloud_microphys_mod_driver ( enddo enddo + pfils = 0. + pflls = 0. + ! ----------------------------------------------------------------------- ! major cloud microphysics ! ----------------------------------------------------------------------- @@ -494,6 +498,12 @@ subroutine gfdl_cloud_microphys_mod_driver ( m2_sol, cond (:, j), area (:, j), land (:, j), udt, vdt, pt_dt, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & vt_s, vt_g, vt_i, qn2) + do k = ktop, kbot + do i = is, ie + pfils(i, j, k) = m2_sol (i, k) + pflls(i, j, k) = m2_rain(i, k) + enddo + enddo enddo ! ----------------------------------------------------------------------- From f1362c2db2cd0b79f71088668edfbec4f67690f3 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Mon, 3 May 2021 16:28:08 +0000 Subject: [PATCH 048/165] Properly handle error flag in PBL generic scheme when aerosol diffusion is enabled. --- physics/GFS_PBL_generic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index ac00672d1..f5eda444f 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -247,7 +247,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, imp_physics_mg, ntgl, imp_physics_gfdl, & imp_physics_zhao_carr, kk, & errmsg, errflg) - if (.not.errflg==1) return + if (errflg /= 0) return ! k1 = kk do n=ntchs,ntchm+ntchs-1 @@ -404,7 +404,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, imp_physics_mg, ntgl, imp_physics_gfdl, & imp_physics_zhao_carr, kk, & errmsg, errflg) - if (.not.errflg==1) return + if (errflg /= 0) return ! k1 = kk do n=ntchs,ntchm+ntchs-1 From d4d90c9e86509b84a21f3ce0bda6c3c38a4bd57c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 May 2021 19:04:20 -0400 Subject: [PATCH 049/165] some optimization of aerosol climo processing --- physics/GFS_phys_time_vary.fv3.F90 | 10 +-- physics/aerinterp.F90 | 125 +++++++++++++++-------------- 2 files changed, 70 insertions(+), 65 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index b4341fb5a..1048a9915 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -312,10 +312,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !$OMP section @@ -870,7 +870,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above call aerinterpol (me, master, nthrds, im, idate, & - fhour, jindx1_aer, jindx2_aer,& + fhour, jindx1_aer, jindx2_aer, & ddy_aer, iindx1_aer, & iindx2_aer, ddx_aer, & levs, prsl, aer_nm) diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index 25472632f..f26dd2968 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -98,7 +98,7 @@ END SUBROUTINE read_aerdata ! !********************************************************************** SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & - me, master, iflip, idate, errmsg, errflg) + me, master, iflip, idate, errmsg, errflg) use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def use netcdf @@ -172,23 +172,23 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & call nf_get_var(ncid, varid, buffx) do j = jamin, jamax - do k = 1, levsaer + do k = 1, levsaer ! input is from toa to sfc - if ( iflip == 0 ) then ! data from toa to sfc - klev = k - else ! data from sfc to top - klev = ( levsw - k ) + 1 - endif - do i = iamin, iamax - aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) - if(aerin(i,j,k,ii,imon)<0.or.aerin(i,j,k,ii,imon)>1.) then - aerin(i,j,k,ii,imon) = 1.e-15 - end if - enddo !i-loop (lon) - enddo !k-loop (lev) - enddo !j-loop (lat) - - ENDDO ! ii-loop (ntracaerm) + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( levsw - k ) + 1 + endif + do i = iamin, iamax + aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) + if(aerin(i,j,k,ii,imon) < 0 .or. aerin(i,j,k,ii,imon) > 1.) then + aerin(i,j,k,ii,imon) = 1.e-15 + endif + enddo !i-loop (lon) + enddo !k-loop (lev) + enddo !j-loop (lat) + + ENDDO ! ii-loop (ntracaerm) ! close the file call nf_close(ncid) @@ -199,7 +199,7 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & END SUBROUTINE read_aerdataf ! SUBROUTINE setindxaer(npts,dlat,jindx1,jindx2,ddy,dlon, & - iindx1,iindx2,ddx,me,master) + iindx1,iindx2,ddx,me,master) ! USE MACHINE, ONLY: kind_phys use aerclm_def, only: aer_lat, jaero=>latsaer, & @@ -257,16 +257,17 @@ END SUBROUTINE setindxaer !********************************************************************** ! SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & - ddy,iindx1,iindx2,ddx,lev,prsl,aerout) + ddy,iindx1,iindx2,ddx,lev,prsl,aerout) ! USE MACHINE, ONLY : kind_phys use aerclm_def implicit none integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii - real(kind=kind_phys) fhour,temj, tx1, tx2,temi + real(kind=kind_phys) fhour,temj, tx1, tx2,temi, & + temij,temiy,temjx,ddxy ! - integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) + integer JINDX1(npts), JINDX2(npts), iINDX1(npts), iINDX2(npts) integer me,idate(4), master, nthrds integer IDAT(8),JDAT(8) ! @@ -279,16 +280,16 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & real(4) rinc4(5) integer w3kindreal,w3kindint ! - IDAT=0 - IDAT(1)=IDATE(4) - IDAT(2)=IDATE(2) - IDAT(3)=IDATE(3) - IDAT(5)=IDATE(1) - RINC=0. - RINC(2)=FHOUR + IDAT = 0 + IDAT(1) = IDATE(4) + IDAT(2) = IDATE(2) + IDAT(3) = IDATE(3) + IDAT(5) = IDATE(1) + RINC = 0. + RINC(2) = FHOUR call w3kind(w3kindreal,w3kindint) - if(w3kindreal==4) then - rinc4=rinc + if(w3kindreal == 4) then + rinc4 = rinc CALL W3MOVDAT(RINC4,IDAT,JDAT) else CALL W3MOVDAT(RINC,IDAT,JDAT) @@ -299,11 +300,11 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & jday = 0 call w3doxdat(jdat,jdow,jdoy,jday) rjday = jdoy + jdat(5) / 24. - IF (RJDAY .LT. aer_time(1)) RJDAY = RJDAY+365. + IF (RJDAY < aer_time(1)) RJDAY = RJDAY+365. ! n2 = 13 do j=2, 12 - if (rjday .lt. aer_time(j)) then + if (rjday < aer_time(j)) then n2 = j exit endif @@ -320,31 +321,36 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & !$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & !$OMP shared(aerpm,aerpres,aerout,n1,n2,lev,nthrds) & !$OMP private(l,j,k,ii,i1,i2,j1,j2,temj,temi) & +!$OMP private(temij,temiy,temjx,ddxy) & !$OMP copyin(tx1,tx2) firstprivate(tx1,tx2) !$OMP do #endif DO L=1,levsaer DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) - I1 = IINDX1(J) - I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) + J1 = JINDX1(J) + J2 = JINDX2(J) + TEMJ = 1.0 - DDY(J) + I1 = IINDX1(J) + I2 = IINDX2(J) + TEMI = 1.0 - DDX(J) + temij = TEMI*TEMJ + temiy = TEMI*DDY(j) + temjx = TEMJ*DDX(j) + ddxy = DDX(j)*DDY(J) DO ii=1,ntrcaer - aerpm(j,L,ii) = & - tx1*(TEMI*TEMJ*aerin(I1,J1,L,ii,n1)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n1)& - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n1)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n1))& - +tx2*(TEMI*TEMJ*aerin(I1,J1,L,ii,n2)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n2) & - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n2)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n2)) + aerpm(j,L,ii) = & + tx1*(TEMIJ*aerin(I1,J1,L,ii,n1)+DDXY*aerin(I2,J2,L,ii,n1) & + +TEMIY*aerin(I1,J2,L,ii,n1)+temjx*aerin(I2,J1,L,ii,n1))& + +tx2*(TEMIJ*aerin(I1,J1,L,ii,n2)+DDXY*aerin(I2,J2,L,ii,n2) & + +TEMIY*aerin(I1,J2,L,ii,n2)+temjx*aerin(I2,J1,L,ii,n2)) ENDDO - aerpres(j,L) = & - tx1*(TEMI*TEMJ*aer_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n1)& - +TEMI*DDY(j)*aer_pres(I1,J2,L,n1)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n1))& - +tx2*(TEMI*TEMJ*aer_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n2) & - +TEMI*DDY(j)*aer_pres(I1,J2,L,n2)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n2)) + aerpres(j,L) = & + tx1*(TEMIJ*aer_pres(I1,J1,L,n1)+DDXY*aer_pres(I2,J2,L,n1) & + +TEMIY*aer_pres(I1,J2,L,n1)+temjx*aer_pres(I2,J1,L,n1))& + +tx2*(TEMIJ*aer_pres(I1,J1,L,n2)+DDXY*aer_pres(I2,J2,L,n2) & + +TEMIY*aer_pres(I1,J2,L,n2)+temjx*aer_pres(I2,J1,L,n2)) ENDDO ENDDO #ifndef __GFORTRAN__ @@ -355,28 +361,27 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & #endif DO J=1,npts DO L=1,lev - if(prsl(j,L).ge.aerpres(j,1)) then + if(prsl(j,L) >= aerpres(j,1)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,1,ii) !! sfc level + aerout(j,L,ii) = aerpm(j,1,ii) !! sfc level ENDDO - else if(prsl(j,L).le.aerpres(j,levsaer)) then + else if(prsl(j,L) <= aerpres(j,levsaer)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,levsaer,ii) !! toa top + aerout(j,L,ii) = aerpm(j,levsaer,ii) !! toa top ENDDO else DO k=1, levsaer-1 !! from sfc to toa - IF(prsl(j,L)aerpres(j,k+1)) then - i1=k - i2=min(k+1,levsaer) + IF(prsl(j,L) < aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then + i1 = k + i2 = min(k+1,levsaer) exit ENDIF ENDDO - temi = prsl(j,L)-aerpres(j,i2) - temj = aerpres(j,i1) - prsl(j,L) - tx1 = temi/(aerpres(j,i1) - aerpres(j,i2)) - tx2 = temj/(aerpres(j,i1) - aerpres(j,i2)) + temi = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) + tx1 = (prsl(j,L) - aerpres(j,i2)) * temi + tx2 = (aerpres(j,i1) - prsl(j,L)) * temi DO ii = 1, ntrcaer - aerout(j,L,ii)= aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 + aerout(j,L,ii) = aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 ENDDO endif ENDDO !L-loop From cfdd5ad52f248b453a9994a39e0245cfd6198bb6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 7 May 2021 20:52:55 -0400 Subject: [PATCH 050/165] some code optimization --- physics/GFS_time_vary_pre.fv3.F90 | 5 +- physics/GFS_time_vary_pre.fv3.meta | 24 -- physics/aerinterp.F90 | 49 +-- physics/flake_driver.F90 | 467 +++++++++++++++-------------- physics/flake_driver.F90_orig | 411 +++++++++++++++++++++++++ physics/sfc_nst.f | 6 + physics/sfc_sice.f | 17 +- physics/sfc_sice.meta | 8 + 8 files changed, 701 insertions(+), 286 deletions(-) create mode 100644 physics/flake_driver.F90_orig diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 98ac6a07f..4b7648c38 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -66,7 +66,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, nhfrad, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, & kdt, julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -76,8 +76,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahm integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lkm, lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc, nhfrad logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 6266889aa..16a124c12 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -76,30 +76,6 @@ kind = kind_phys intent = in optional = F -[lkm] - standard_name = flag_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index f26dd2968..f59405e72 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -263,8 +263,8 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & use aerclm_def implicit none integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii - real(kind=kind_phys) fhour,temj, tx1, tx2,temi, & - temij,temiy,temjx,ddxy + real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem + real(kind=kind_phys), dimension(npts) :: temij,temiy,temjx,ddxy ! integer JINDX1(npts), JINDX2(npts), iINDX1(npts), iINDX2(npts) @@ -315,13 +315,22 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & tx2 = 1.0 - tx1 if (n2 > 12) n2 = n2 -12 + do j=1,npts + TEMJ = 1.0 - DDY(J) + TEMI = 1.0 - DDX(J) + temij(j) = TEMI*TEMJ + temiy(j) = TEMI*DDY(j) + temjx(j) = TEMJ*DDX(j) + ddxy(j) = DDX(j)*DDY(J) + enddo + #ifndef __GFORTRAN__ !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(npts,ntrcaer,aerin,aer_pres,prsl) & !$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & !$OMP shared(aerpm,aerpres,aerout,n1,n2,lev,nthrds) & -!$OMP private(l,j,k,ii,i1,i2,j1,j2,temj,temi) & -!$OMP private(temij,temiy,temjx,ddxy) & +!$OMP shared(temij,temiy,temjx,ddxy) & +!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem) & !$OMP copyin(tx1,tx2) firstprivate(tx1,tx2) !$OMP do @@ -330,27 +339,21 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & DO J=1,npts J1 = JINDX1(J) J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) I1 = IINDX1(J) I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) - temij = TEMI*TEMJ - temiy = TEMI*DDY(j) - temjx = TEMJ*DDX(j) - ddxy = DDX(j)*DDY(J) DO ii=1,ntrcaer - aerpm(j,L,ii) = & - tx1*(TEMIJ*aerin(I1,J1,L,ii,n1)+DDXY*aerin(I2,J2,L,ii,n1) & - +TEMIY*aerin(I1,J2,L,ii,n1)+temjx*aerin(I2,J1,L,ii,n1))& - +tx2*(TEMIJ*aerin(I1,J1,L,ii,n2)+DDXY*aerin(I2,J2,L,ii,n2) & - +TEMIY*aerin(I1,J2,L,ii,n2)+temjx*aerin(I2,J1,L,ii,n2)) + aerpm(j,L,ii) = & + tx1*(TEMIJ(j)*aerin(I1,J1,L,ii,n1)+DDXY(j)*aerin(I2,J2,L,ii,n1) & + +TEMIY(j)*aerin(I1,J2,L,ii,n1)+temjx(j)*aerin(I2,J1,L,ii,n1))& + +tx2*(TEMIJ(j)*aerin(I1,J1,L,ii,n2)+DDXY(j)*aerin(I2,J2,L,ii,n2) & + +TEMIY(j)*aerin(I1,J2,L,ii,n2)+temjx(j)*aerin(I2,J1,L,ii,n2)) ENDDO - aerpres(j,L) = & - tx1*(TEMIJ*aer_pres(I1,J1,L,n1)+DDXY*aer_pres(I2,J2,L,n1) & - +TEMIY*aer_pres(I1,J2,L,n1)+temjx*aer_pres(I2,J1,L,n1))& - +tx2*(TEMIJ*aer_pres(I1,J1,L,n2)+DDXY*aer_pres(I2,J2,L,n2) & - +TEMIY*aer_pres(I1,J2,L,n2)+temjx*aer_pres(I2,J1,L,n2)) + aerpres(j,L) = & + tx1*(TEMIJ(j)*aer_pres(I1,J1,L,n1)+DDXY(j)*aer_pres(I2,J2,L,n1) & + +TEMIY(j)*aer_pres(I1,J2,L,n1)+temjx(j)*aer_pres(I2,J1,L,n1))& + +tx2*(TEMIJ(j)*aer_pres(I1,J1,L,n2)+DDXY(j)*aer_pres(I2,J2,L,n2) & + +TEMIY(j)*aer_pres(I1,J2,L,n2)+temjx(j)*aer_pres(I2,J1,L,n2)) ENDDO ENDDO #ifndef __GFORTRAN__ @@ -377,9 +380,9 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & exit ENDIF ENDDO - temi = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) - tx1 = (prsl(j,L) - aerpres(j,i2)) * temi - tx2 = (aerpres(j,i1) - prsl(j,L)) * temi + tem = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) + tx1 = (prsl(j,L) - aerpres(j,i2)) * tem + tx2 = (aerpres(j,i1) - prsl(j,L)) * tem DO ii = 1, ntrcaer aerout(j,L,ii) = aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 ENDDO diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index 1e8714461..94fe8286b 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -62,13 +62,13 @@ SUBROUTINE flake_driver_run ( & ! ! Declarations ! use module_flake_ini, only:flake_init - use module_FLake + use module_FLake ! use flake_albedo_ref ! use data_parameters ! use flake_derivedtypes -! use flake_paramoptic_ref +! use flake_paramoptic_ref ! use flake_parameters - use machine , only : kind_phys + use machine , only : kind_phys ! use funcphys, only : fpvs ! use physcons, only : grav => con_g, cp => con_cp, & ! & hvap => con_hvap, rd => con_rd, & @@ -76,10 +76,10 @@ SUBROUTINE flake_driver_run ( & ! & rvrdm1 => con_fvirt !============================================================================== -IMPLICIT NONE + implicit none integer, intent(in) :: im, imon,yearlen -! integer, dimension(im), intent(in) :: islmsk +! integer, dimension(im), intent(in) :: islmsk real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev @@ -91,7 +91,7 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys),dimension(:),intent(inout) :: & & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm + & ch, cm, chh, cmm real (kind=kind_phys), intent(in) :: julian @@ -116,184 +116,190 @@ SUBROUTINE flake_driver_run ( & h_ML , & ! Thickness of the mixed-layer [m] H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! - w_extinc + w_extinc ! Input (procedure arguments) -REAL (KIND = kind_phys) :: & - - dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] - I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] - Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] - height_u_in , & ! Height above the lake surface where the wind speed is measured [m] - height_tq_in , & ! Height where temperature and humidity are measured [m] - U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] - T_a_in , & ! Air temperature at z=height_tq_in [K] - q_a_in , & ! Air specific humidity at z=height_tq_in - P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] - -REAL (KIND = kind_phys) :: & - depth_w , & ! The lake depth [m] - fetch_in , & ! Typical wind fetch [m] - depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] - T_bs_in , & ! Temperature at the outer edge of + REAL (KIND = kind_phys) :: & + + dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] + I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] + Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] + height_u_in , & ! Height above the lake surface where the wind speed is measured [m] + height_tq_in , & ! Height where temperature and humidity are measured [m] + U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] + T_a_in , & ! Air temperature at z=height_tq_in [K] + q_a_in , & ! Air specific humidity at z=height_tq_in + P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] + + REAL (KIND = kind_phys) :: & + depth_w , & ! The lake depth [m] + fetch_in , & ! Typical wind fetch [m] + depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] + T_bs_in , & ! Temperature at the outer edge of ! the thermally active layer of the bottom sediments [K] - par_Coriolis , & ! The Coriolis parameter [s^{-1}] - del_time ! The model time step [s] - -REAL (KIND = kind_phys) :: & - T_snow_in , & ! Temperature at the air-snow interface [K] - T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_in , & ! Mean temperature of the water column [K] - T_wML_in , & ! Mixed-layer temperature [K] - T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_in , & ! Shape factor (thermocline) - h_snow_in , & ! Snow thickness [m] - h_ice_in , & ! Ice thickness [m] - h_ML_in , & ! Thickness of the mixed-layer [m] - H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_in , & ! Surface temperature at the previous time step [K] - ch_in , & - cm_in , & - albedo_water , & - water_extinc - -REAL (KIND = kind_phys) :: & - T_snow_out , & ! Temperature at the air-snow interface [K] - T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_out , & ! Mean temperature of the water column [K] - T_wML_out , & ! Mixed-layer temperature [K] - T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_out , & ! Shape factor (thermocline) - h_snow_out , & ! Snow thickness [m] - h_ice_out , & ! Ice thickness [m] - h_ML_out , & ! Thickness of the mixed-layer [m] - H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_out , & ! surface temperature [K] - T_sfc_n , & ! Updated surface temperature [K] - u_star , & - q_sfc , & - chh_out , & - cmm_out - -REAL (KIND = kind_phys) :: & - Q_momentum , & ! Momentum flux [N m^{-2}] - Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] - Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] - -REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,Kbar, DelK - - -REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc - !initilizations - -INTEGER :: i,ipr,iter - -LOGICAL :: lflk_botsed_use -logical :: flag(im) -CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" + par_Coriolis , & ! The Coriolis parameter [s^{-1}] + del_time ! The model time step [s] + + REAL (KIND = kind_phys) :: & + T_snow_in , & ! Temperature at the air-snow interface [K] + T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_in , & ! Mean temperature of the water column [K] + T_wML_in , & ! Mixed-layer temperature [K] + T_bot_in , & ! Temperature at the water-bottom sediment interface [K] + T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_in , & ! Shape factor (thermocline) + h_snow_in , & ! Snow thickness [m] + h_ice_in , & ! Ice thickness [m] + h_ML_in , & ! Thickness of the mixed-layer [m] + H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_in , & ! Surface temperature at the previous time step [K] + ch_in , & + cm_in , & + albedo_water , & + water_extinc + + REAL (KIND = kind_phys) :: & + T_snow_out , & ! Temperature at the air-snow interface [K] + T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_out , & ! Mean temperature of the water column [K] + T_wML_out , & ! Mixed-layer temperature [K] + T_bot_out , & ! Temperature at the water-bottom sediment interface [K] + T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_out , & ! Shape factor (thermocline) + h_snow_out , & ! Snow thickness [m] + h_ice_out , & ! Ice thickness [m] + h_ML_out , & ! Thickness of the mixed-layer [m] + H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_out , & ! surface temperature [K] + T_sfc_n , & ! Updated surface temperature [K] + u_star , & + q_sfc , & + chh_out , & + cmm_out + + REAL (KIND = kind_phys) :: & + Q_momentum , & ! Momentum flux [N m^{-2}] + Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] + Q_LHT_flx , & ! Latent heat flux [W m^{-2}] + Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] + + REAL (KIND = kind_phys) :: & + lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,temp2 + + real (kind=kind_phys), parameter :: pi=4.0_kind_phys*atan(1.0_kind_phys) + real (kind=kind_phys), parameter :: degrad=180.0_kind_phys/pi + real (kind=kind_phys), parameter :: Kbar = 3.5_kind_phys, DelK = 3.0_kind_phys, & + KbaroDelK = Kbar / DelK + + REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc + !initilizations + + INTEGER :: i,ipr,iter + + LOGICAL :: lflk_botsed_use, do_flake + logical :: flag(im) +! CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" !============================================================================== ! Start calculations !------------------------------------------------------------------------------ -! FLake_write need to assign original value to make the model somooth - - lake_depth_max = 60.0 - ipr = min(im,10) +! FLake_write need to assign original value to make the model somooth ! --- ... set flag for lake points + do_flake = .false. do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) + flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i) + do_flake = flag(i) .or. do_flake enddo - Kbar=3.5 - DelK=3.0 + if (.not. do_flake) return + + lake_depth_max = 60.0 + ipr = min(im,10) + + x = 0.03279*julian + y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 + + temp = (pi+pi)*(julian-1)/float(yearlen) + temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp) & + - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) & + - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) + + temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im if (flag(i)) then - if( use_flake(i) ) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = 57.29578*abs(xlat(i)) - tt = 29.275+0.0813*dxlat-0.0052*dxlat*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-0.7566*dxlat+0.0051*dxlat*dxlat-0.0038*elev(i)+273.15 -! if(fice(i).le.0.0) then -! h_ice(i) = 0.0 -! h_snow(i)= 0.0 + T_ice(i) = 273.15 + T_snow(i) = 273.15 + fetch(i) = 2.0E+03 + C_T(i) = 0.50 + + dxlat = degrad*abs(xlat(i)) + tt = 29.275+(0.0813-0.0052*dxlat)*dxlat-0.0038*elev(i)+273.15 + tb = 29.075-(0.7566-0.0051*dxlat)*dxlat-0.0038*elev(i)+273.15 +! if (fice(i).le.0.0) then +! h_ice(i) = 0.0 +! h_snow(i)= 0.0 +! endif + if (snwdph(i) > 0.0 .or. hice(i) > 0.0) then + if (tsurf(i) < T_ice(i)) then + T_sfc(i) = T_ice(i) + else + T_sfc(i) = tsurf(i) + endif + else +! if (tsurf(i) < tt) then +! T_sfc(i) = tt +! else +! T_sfc(i) = tsurf(i) ! endif - if(snwdph(i).gt.0.0 .or. hice(i).gt.0.0) then - if(tsurf(i).lt.T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if(tsurf(i).lt.tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* tsurf(i) - endif + T_sfc(i) = 0.1*tt + 0.9* tsurf(i) + endif ! ! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot ! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair ! in Summer - x = 0.03279*julian - if(xlat(i) .ge. 0.0) then - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) - 0.3*y - tb = tb - 0.05*y - endif - T_bot(i) = tb - T_B1(i) = tb - -! if(lakedepth(i).lt.10.0) then -! T_bot(i) = T_sfc(i) -! T_B1(i) = T_bot(i) -! endif - - T_mnw(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - T_wML(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B1(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - evap(i) = 0.0 - -! compute albedo as a function of julian day and latitute - temp = 2*3.14159265*(julian-1)/float(yearlen) - temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp)- & - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) - & - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) - w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) -! w_albedo(I) = 0.06 + if (xlat(i) >= 0.0) then + T_sfc(i) = T_sfc(i) + 0.3*y + tb = tb + 0.05*y + else + T_sfc(i) = T_sfc(i) - 0.3*y + tb = tb - 0.05*y + endif + T_bot(i) = tb + T_B1(i) = tb + +! if (lakedepth(i) < 10.0) then +! T_bot(i) = T_sfc(i) +! T_B1(i) = T_bot(i) +! endif + + T_mnw(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + T_wML(i) = C_T(i)*T_sfc(i) + (1-C_T(i))*T_bot(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B1(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + evap(i) = 0.0 + +! compute albedo as a function of julian day and latitude + w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) +! w_albedo(I) = 0.06 ! compute water extinction coefficient as a function of julian day - if(julian.lt.90 .or. julian .gt. 333) then - w_extinc(i) = Kbar-Kbar/DelK - else - w_extinc(i) = Kbar+Kbar/DelK*sin(2*3.14159265*(julian-151)/244) - endif -! w_extinc(i) = 3.0 + if (julian < 90 .or. julian > 333) then + w_extinc(i) = Kbar - KbaroDelK + else + w_extinc(i) = Kbar + KbaroDelK*temp2 + endif +! w_extinc(i) = 3.0 ! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) ! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) ! print*,'inside flake driver' ! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) - endif !lake endif !flag enddo 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & @@ -302,55 +308,54 @@ SUBROUTINE flake_driver_run ( & 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) -! +! ! call lake interface do i=1,im - if (flag(i)) then - if( use_flake(i) ) then - dMsnowdt_in = weasd(i)/delt - I_atm_in = dswsfc(i) - Q_atm_lw_in = dlwflx(i) - height_u_in = zlvl(i) - height_tq_in = zlvl(i) - U_a_in = wind(i) - T_a_in = t1(i) - q_a_in = q1(i) - P_a_in = ps(i) - ch_in = ch(i) - cm_in = cm(i) - albedo_water= w_albedo(i) - water_extinc= w_extinc(i) - - depth_w = min ( lakedepth(i), lake_depth_max ) - depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) - fetch_in = fetch(i) - T_bs_in = T_bot(i) - par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) - del_time = delt - - do iter=1,10 !interation loop - T_snow_in = T_snow(i) - T_ice_in = T_ice(i) - T_mnw_in = T_mnw(i) - T_wML_in = T_wML(i) - T_bot_in = T_bot(i) - T_B1_in = T_B1(i) - C_T_in = C_T(i) - h_snow_in = snwdph(i) - h_ice_in = hice(i) - h_ML_in = h_ML(i) - H_B1_in = H_B1(i) - T_sfc_in = T_sfc(i) - - T_bot_2_in = T_bot(i) - Q_SHT_flx = hflx(i) - Q_watvap = evap(i) + if (flag(i)) then + dMsnowdt_in = weasd(i)/delt + I_atm_in = dswsfc(i) + Q_atm_lw_in = dlwflx(i) + height_u_in = zlvl(i) + height_tq_in = zlvl(i) + U_a_in = wind(i) + T_a_in = t1(i) + q_a_in = q1(i) + P_a_in = ps(i) + ch_in = ch(i) + cm_in = cm(i) + albedo_water = w_albedo(i) + water_extinc = w_extinc(i) + + depth_w = min ( lakedepth(i), lake_depth_max ) + depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) + fetch_in = fetch(i) + T_bs_in = T_bot(i) + par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) + del_time = delt + + do iter=1,10 !interation loop + T_snow_in = T_snow(i) + T_ice_in = T_ice(i) + T_mnw_in = T_mnw(i) + T_wML_in = T_wML(i) + T_bot_in = T_bot(i) + T_B1_in = T_B1(i) + C_T_in = C_T(i) + h_snow_in = snwdph(i) + h_ice_in = hice(i) + h_ML_in = h_ML(i) + H_B1_in = H_B1(i) + T_sfc_in = T_sfc(i) + + T_bot_2_in = T_bot(i) + Q_SHT_flx = hflx(i) + Q_watvap = evap(i) !------------------------------------------------------------------------------ ! Set the rate of snow accumulation !------------------------------------------------------------------------------ - CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & + CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & @@ -362,45 +367,45 @@ SUBROUTINE flake_driver_run ( & T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & ! - T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) + T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) !------------------------------------------------------------------------------ ! Update output and values for previous time step ! - T_snow(i) = T_snow_out - T_ice(i) = T_ice_out - T_mnw(i) = T_mnw_out - T_wML(i) = T_wML_out - T_sfc(i) = T_sfc_out - Tsurf(i) = T_sfc_out - T_bot(i) = T_bot_out - T_B1(i) = T_B1_out - C_T(i) = C_T_out - h_ML(i) = h_ML_out - H_B1(i) = H_B1_out - ustar(i) = u_star - qsfc(i) = q_sfc - chh(i) = chh_out - cmm(i) = cmm_out - snwdph(i) = h_snow_out - hice(i) = h_ice_out - evap(i) = Q_watvap - hflx(i) = Q_SHT_flx - - if(hice(i) .gt. 0.0 .or. snwdph(i) .gt. 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif - enddo !iter loop - endif !endif of lake - endif !endif of flag - - ENDDO - - 125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) - 126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) - 127 format(1x,i2,2(1x,f16.9)) + T_snow(i) = T_snow_out + T_ice(i) = T_ice_out + T_mnw(i) = T_mnw_out + T_wML(i) = T_wML_out + T_sfc(i) = T_sfc_out + Tsurf(i) = T_sfc_out + T_bot(i) = T_bot_out + T_B1(i) = T_B1_out + C_T(i) = C_T_out + h_ML(i) = h_ML_out + H_B1(i) = H_B1_out + ustar(i) = u_star + qsfc(i) = q_sfc + chh(i) = chh_out + cmm(i) = cmm_out + snwdph(i) = h_snow_out + hice(i) = h_ice_out + evap(i) = Q_watvap + hflx(i) = Q_SHT_flx + + if (hice(i) > 0.0 .or. snwdph(i) > 0.0) then + fice(i) = 1.0 + else + fice(i) = 0.0 + endif + enddo !iter loop + + endif !endif of flag + + enddo + +!125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) +!126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) +!127 format(1x,i2,2(1x,f16.9)) !------------------------------------------------------------------------------ ! End calculations !============================================================================== diff --git a/physics/flake_driver.F90_orig b/physics/flake_driver.F90_orig new file mode 100644 index 000000000..1e8714461 --- /dev/null +++ b/physics/flake_driver.F90_orig @@ -0,0 +1,411 @@ +!> \file flake_driver.F90 +!! This file contains the flake scheme driver. + +!> This module contains the CCPP-compliant flake scheme driver. + module flake_driver + + implicit none + + private + + public :: flake_driver_init, flake_driver_run, flake_driver_finalize + + contains + +!> \section arg_table_flake_driver_init Argument Table +!! \htmlinclude flake_driver_init.html +!! + subroutine flake_driver_init (errmsg, errflg) + + implicit none + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine flake_driver_init + +!> \section arg_table_flake_driver_finalize Argument Table +!! \htmlinclude flake_driver_finalize.html +!! + subroutine flake_driver_finalize (errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + end subroutine flake_driver_finalize + +!> \section arg_table_flake_driver_run Argument Table +!! \htmlinclude flake_driver_run.html +!! + SUBROUTINE flake_driver_run ( & +! ---- Inputs + im, ps, t1, q1, wind, & + dlwflx, dswsfc, weasd, lakedepth, & + use_flake, xlat, delt, zlvl, elev, & + wet, flag_iter, yearlen, julian, imon, & +! ---- in/outs + snwdph, hice, tsurf, fice, T_sfc, hflx, evap, & + ustar, qsfc, ch, cm, chh, cmm, & + errmsg, errflg ) + +!============================================================================== +! +! Declarations +! use module_flake_ini, only:flake_init + use module_FLake +! use flake_albedo_ref +! use data_parameters +! use flake_derivedtypes +! use flake_paramoptic_ref +! use flake_parameters + use machine , only : kind_phys +! use funcphys, only : fpvs +! use physcons, only : grav => con_g, cp => con_cp, & +! & hvap => con_hvap, rd => con_rd, & +! & eps => con_eps, epsm1 => con_epsm1, & +! & rvrdm1 => con_fvirt + +!============================================================================== +IMPLICIT NONE + + integer, intent(in) :: im, imon,yearlen +! integer, dimension(im), intent(in) :: islmsk + + real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & + & t1, q1, dlwflx, dswsfc, zlvl, elev + + real (kind=kind_phys), intent(in) :: delt + + real (kind=kind_phys), dimension(:), intent(in) :: & + & xlat, weasd, lakedepth + + real (kind=kind_phys),dimension(:),intent(inout) :: & + & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & + & ch, cm, chh, cmm + + real (kind=kind_phys), intent(in) :: julian + + logical, dimension(:), intent(in) :: flag_iter, wet, use_flake + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! --- locals + + real (kind=kind_phys) , parameter :: lake_pct_min = 0.1 + + real (kind=kind_phys), dimension(im) :: & + T_snow , & ! Temperature at the air-snow interface [K] + T_ice , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw , & ! Mean temperature of the water column [K] + T_wML , & ! Mixed-layer temperature [K] + T_bot , & ! Temperature at the water-bottom sediment interface [K] + T_B1 , & ! Temperature at the upper layer of the sediments [K] + C_T , & ! Shape factor (thermocline) + fetch , & ! Typical wind fetch [m] + h_ML , & ! Thickness of the mixed-layer [m] + H_B1 , & ! Thickness of the upper layer of bottom sediments [m] + w_albedo , & ! + w_extinc + +! Input (procedure arguments) + +REAL (KIND = kind_phys) :: & + + dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] + I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] + Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] + height_u_in , & ! Height above the lake surface where the wind speed is measured [m] + height_tq_in , & ! Height where temperature and humidity are measured [m] + U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] + T_a_in , & ! Air temperature at z=height_tq_in [K] + q_a_in , & ! Air specific humidity at z=height_tq_in + P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] + +REAL (KIND = kind_phys) :: & + depth_w , & ! The lake depth [m] + fetch_in , & ! Typical wind fetch [m] + depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] + T_bs_in , & ! Temperature at the outer edge of + ! the thermally active layer of the bottom sediments [K] + par_Coriolis , & ! The Coriolis parameter [s^{-1}] + del_time ! The model time step [s] + +REAL (KIND = kind_phys) :: & + T_snow_in , & ! Temperature at the air-snow interface [K] + T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_in , & ! Mean temperature of the water column [K] + T_wML_in , & ! Mixed-layer temperature [K] + T_bot_in , & ! Temperature at the water-bottom sediment interface [K] + T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_in , & ! Shape factor (thermocline) + h_snow_in , & ! Snow thickness [m] + h_ice_in , & ! Ice thickness [m] + h_ML_in , & ! Thickness of the mixed-layer [m] + H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_in , & ! Surface temperature at the previous time step [K] + ch_in , & + cm_in , & + albedo_water , & + water_extinc + +REAL (KIND = kind_phys) :: & + T_snow_out , & ! Temperature at the air-snow interface [K] + T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] + T_mnw_out , & ! Mean temperature of the water column [K] + T_wML_out , & ! Mixed-layer temperature [K] + T_bot_out , & ! Temperature at the water-bottom sediment interface [K] + T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] + C_T_out , & ! Shape factor (thermocline) + h_snow_out , & ! Snow thickness [m] + h_ice_out , & ! Ice thickness [m] + h_ML_out , & ! Thickness of the mixed-layer [m] + H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_out , & ! surface temperature [K] + T_sfc_n , & ! Updated surface temperature [K] + u_star , & + q_sfc , & + chh_out , & + cmm_out + +REAL (KIND = kind_phys) :: & + Q_momentum , & ! Momentum flux [N m^{-2}] + Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] + Q_LHT_flx , & ! Latent heat flux [W m^{-2}] + Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] + +REAL (KIND = kind_phys) :: & + lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,Kbar, DelK + + +REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc + !initilizations + +INTEGER :: i,ipr,iter + +LOGICAL :: lflk_botsed_use +logical :: flag(im) +CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" + +!============================================================================== +! Start calculations +!------------------------------------------------------------------------------ +! FLake_write need to assign original value to make the model somooth + + lake_depth_max = 60.0 + ipr = min(im,10) + +! --- ... set flag for lake points + + do i = 1, im + flag(i) = (wet(i) .and. flag_iter(i)) + enddo + + Kbar=3.5 + DelK=3.0 + + do i = 1, im + if (flag(i)) then + if( use_flake(i) ) then + T_ice(i) = 273.15 + T_snow(i) = 273.15 + fetch(i) = 2.0E+03 + C_T(i) = 0.50 + + dxlat = 57.29578*abs(xlat(i)) + tt = 29.275+0.0813*dxlat-0.0052*dxlat*dxlat-0.0038*elev(i)+273.15 + tb = 29.075-0.7566*dxlat+0.0051*dxlat*dxlat-0.0038*elev(i)+273.15 +! if(fice(i).le.0.0) then +! h_ice(i) = 0.0 +! h_snow(i)= 0.0 +! endif + if(snwdph(i).gt.0.0 .or. hice(i).gt.0.0) then + if(tsurf(i).lt.T_ice(i)) then + T_sfc(i) = T_ice(i) + else + T_sfc(i) = tsurf(i) + endif + else +! if(tsurf(i).lt.tt) then +! T_sfc(i) = tt +! else +! T_sfc(i) = tsurf(i) +! endif + T_sfc(i) = 0.1*tt + 0.9* tsurf(i) + endif +! +! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot +! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair +! in Summer + + x = 0.03279*julian + if(xlat(i) .ge. 0.0) then + y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 + T_sfc(i) = T_sfc(i) + 0.3*y + tb = tb + 0.05*y + else + y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 + T_sfc(i) = T_sfc(i) - 0.3*y + tb = tb - 0.05*y + endif + T_bot(i) = tb + T_B1(i) = tb + +! if(lakedepth(i).lt.10.0) then +! T_bot(i) = T_sfc(i) +! T_B1(i) = T_bot(i) +! endif + + T_mnw(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) + T_wML(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) + h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) + H_B1(i) = min ( lakedepth(i),4.0) + hflx(i) = 0.0 + evap(i) = 0.0 + +! compute albedo as a function of julian day and latitute + temp = 2*3.14159265*(julian-1)/float(yearlen) + temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp)- & + 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) - & + 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) + w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) +! w_albedo(I) = 0.06 +! compute water extinction coefficient as a function of julian day + if(julian.lt.90 .or. julian .gt. 333) then + w_extinc(i) = Kbar-Kbar/DelK + else + w_extinc(i) = Kbar+Kbar/DelK*sin(2*3.14159265*(julian-151)/244) + endif +! w_extinc(i) = 3.0 + +! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) +! print*,'inside flake driver' +! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) + + endif !lake + endif !flag + enddo + 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & + 1p, e12.3) +! 1002 format ( ' julian= ',F6.2,1x,5(F8.4,1x),3(f11.4,1x)) + 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) + + +! +! call lake interface + do i=1,im + if (flag(i)) then + if( use_flake(i) ) then + dMsnowdt_in = weasd(i)/delt + I_atm_in = dswsfc(i) + Q_atm_lw_in = dlwflx(i) + height_u_in = zlvl(i) + height_tq_in = zlvl(i) + U_a_in = wind(i) + T_a_in = t1(i) + q_a_in = q1(i) + P_a_in = ps(i) + ch_in = ch(i) + cm_in = cm(i) + albedo_water= w_albedo(i) + water_extinc= w_extinc(i) + + depth_w = min ( lakedepth(i), lake_depth_max ) + depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) + fetch_in = fetch(i) + T_bs_in = T_bot(i) + par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) + del_time = delt + + do iter=1,10 !interation loop + T_snow_in = T_snow(i) + T_ice_in = T_ice(i) + T_mnw_in = T_mnw(i) + T_wML_in = T_wML(i) + T_bot_in = T_bot(i) + T_B1_in = T_B1(i) + C_T_in = C_T(i) + h_snow_in = snwdph(i) + h_ice_in = hice(i) + h_ML_in = h_ML(i) + H_B1_in = H_B1(i) + T_sfc_in = T_sfc(i) + + T_bot_2_in = T_bot(i) + Q_SHT_flx = hflx(i) + Q_watvap = evap(i) + +!------------------------------------------------------------------------------ +! Set the rate of snow accumulation +!------------------------------------------------------------------------------ + + CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & + height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & + + depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & + T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B1_in, & + C_T_in, h_snow_in, h_ice_in, h_ML_in, H_B1_in, T_sfc_in, & + ch_in, cm_in, albedo_water, water_extinc, & +! + T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & + T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & + H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & +! + T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) + +!------------------------------------------------------------------------------ +! Update output and values for previous time step +! + T_snow(i) = T_snow_out + T_ice(i) = T_ice_out + T_mnw(i) = T_mnw_out + T_wML(i) = T_wML_out + T_sfc(i) = T_sfc_out + Tsurf(i) = T_sfc_out + T_bot(i) = T_bot_out + T_B1(i) = T_B1_out + C_T(i) = C_T_out + h_ML(i) = h_ML_out + H_B1(i) = H_B1_out + ustar(i) = u_star + qsfc(i) = q_sfc + chh(i) = chh_out + cmm(i) = cmm_out + snwdph(i) = h_snow_out + hice(i) = h_ice_out + evap(i) = Q_watvap + hflx(i) = Q_SHT_flx + + if(hice(i) .gt. 0.0 .or. snwdph(i) .gt. 0.0) then + fice(i) = 1.0 + else + fice(i) = 0.0 + endif + enddo !iter loop + endif !endif of lake + endif !endif of flag + + ENDDO + + 125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) + 126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) + 127 format(1x,i2,2(1x,f16.9)) +!------------------------------------------------------------------------------ +! End calculations +!============================================================================== + +END SUBROUTINE flake_driver_run + +!--------------------------------- + end module flake_driver diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 2eaa446af..31d75cffa 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -242,6 +242,7 @@ subroutine sfc_nst_run & real(kind=kind_phys) fw,q_warm real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz real(kind=kind_phys) zsea1,zsea2,soltim + logical do_nst ! external functions called: iw3jdn integer :: iw3jdn @@ -251,6 +252,8 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 + if (nstf_name1 == 0) return ! No NSST model used + cpinv = one/cp hvapi = one/hvap elocp = hvap/cp @@ -259,10 +262,13 @@ subroutine sfc_nst_run & ! ! flag for open water and where the iteration is on ! + do_nst = .false. do i = 1, im ! flag(i) = wet(i) .and. .not.icy(i) .and. flag_iter(i) flag(i) = wet(i) .and. flag_iter(i) .and. .not. use_flake(i) + do_nst = do_nst .or. flag(i) enddo + if (.not. do_nst) return ! ! save nst-related prognostic fields for guess run ! diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 3f510a853..009b5f228 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -45,7 +45,7 @@ subroutine sfc_sice_run & & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, lprnt, ipr, me, & + & flag_iter, use_flake, lprnt, ipr, me, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & & islmsk_cice, & @@ -60,7 +60,7 @@ subroutine sfc_sice_run & ! ! ! call sfc_sice ! ! inputs: ! -! ( im, kice, ps, t1, q1, delt, ! +! ( im, kice, ps, t1, q1, delt, ! ! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! ! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! ! flag_iter, ! @@ -111,6 +111,7 @@ subroutine sfc_sice_run & ! islimsk - integer, sea/land/ice mask (=0/1/2) im ! ! wind - real, im ! ! flag_iter- logical, im ! +! use_flake- logical, true for lakes when when lkm > 0 im ! ! ! ! input/outputs: ! ! hice - real, sea-ice thickness im ! @@ -134,7 +135,7 @@ subroutine sfc_sice_run & ! ! ! ===================================================================== ! ! - use machine, only : kind_phys + use machine, only : kind_phys use funcphys, only : fpvs ! implicit none @@ -168,7 +169,7 @@ subroutine sfc_sice_run & ! real (kind=kind_phys), intent(in) :: delt, min_seaice, & ! & min_lakeice - logical, dimension(im), intent(in) :: flag_iter + logical, dimension(im), intent(in) :: flag_iter, use_flake ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & @@ -194,6 +195,7 @@ subroutine sfc_sice_run & &, hflxi, hflxw, q0, qs1, qssi, qssw real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw ! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + logical do_sice integer :: i, k @@ -211,13 +213,18 @@ subroutine sfc_sice_run & ! !> - Set flag for sea-ice. + do_sice = .false. do i = 1, im - flag(i) = (islmsk_cice(i) == 2) .and. flag_iter(i) +! flag(i) = islmsk_cice(i) == 2 .and. flag_iter(i) + flag(i) = islmsk_cice(i) == 2 .and. flag_iter(i) & + & .and. .not. use_flake(i) + do_sice = do_sice .or. flag(i) ! if (flag_iter(i) .and. islmsk_cice(i) < 2) then ! hice(i) = zero ! fice(i) = zero ! endif enddo + if (.not. do_sice) return do i = 1, im if (flag(i)) then diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index 2d3643160..a378cc379 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -265,6 +265,14 @@ type = logical intent = in optional = F +[use_flake] + standard_name = flag_nonzero_lake_surface_fraction + long_name = flag indicating presence of some lake surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F [lprnt] standard_name = flag_print long_name = switch for printing sample column to stdout From df30cf7c01d3fcd5f5a97ea4569220d1b3da7daf Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Sun, 9 May 2021 19:32:06 +0000 Subject: [PATCH 051/165] Limit full LW flux profile adjustment to below 100hPa. --- physics/dcyc2.f | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index ad9365851..a3d7cf193 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -380,9 +380,12 @@ subroutine dcyc2t3_run & ! do k = 1, levs+1 do i = 1, im - dT = t_lev2(i,k) - t_lev(i,k) - flxlwup_adj(i,k) = flux2D_lwUP(i,k) + & - & fluxlwUP_jac(i,k)*dT + flxlwup_adj(i,k) = flux2D_lwUP(i,k) + if (p_lev(i,k) .gt. 10000.) then + dT = t_lev2(i,k) - t_lev(i,k) + flxlwup_adj(i,k) = flux2D_lwUP(i,k) + & + & fluxlwUP_jac(i,k)*dT + endif enddo enddo ! From 6961b10546035b55021132e62ce139333eed9cc0 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Sun, 9 May 2021 23:50:22 +0000 Subject: [PATCH 052/165] Added more safeguards against out-of-bounds temperature to GP inputs. --- physics/GFS_rrtmgp_pre.F90 | 12 ++++++++---- physics/GFS_rrtmgp_pre.meta | 9 +++++++++ physics/dcyc2.f | 9 +++++---- physics/dcyc2.meta | 18 ++++++++++++++++++ physics/radiation_tools.F90 | 20 ++++++++++++++------ physics/rrtmgp_lw_gas_optics.F90 | 4 +++- physics/rrtmgp_lw_gas_optics.meta | 9 +++++++++ 7 files changed, 66 insertions(+), 15 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index 88e534595..af7e5f1a0 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -98,8 +98,8 @@ end subroutine GFS_rrtmgp_pre_init !! subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps, con_epsm1, con_fvirt, & - con_epsqs, minGPpres, minGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, & - qs_lay, q_lay, tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) + con_epsqs, minGPpres, minGPtemp, maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, & + tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -112,6 +112,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f lslwr ! Call LW radiation real(kind_phys), intent(in) :: & minGPtemp, & ! Minimum temperature allowed in RRTMGP. + maxGPtemp, & ! Maximum temperature allowed in RRTMGP. minGPpres, & ! Minimum pressure allowed in RRTMGP. fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. @@ -208,11 +209,14 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f if (t_lay(iCol,iLay) .le. minGPtemp) then t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) endif + if (t_lay(iCol,iLay) .ge. maxGPtemp) then + t_lay(iCol,iLay) = maxGPtemp - epsilon(maxGPtemp) + endif enddo enddo ! Temperature at layer-interfaces - call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) + call cmp_tlev(nCol,nLev,minGPpres,minGPtemp,maxGPtemp,p_lay,t_lay,p_lev,tsfc,t_lev) ! Compute a bunch of thermodynamic fields needed by the cloud microphysics schemes. ! Relative humidity, saturation mixing-ratio, vapor mixing-ratio, virtual temperature, @@ -273,7 +277,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### - tsfg(1:NCOL) = tsfc(1:NCOL) + tsfg(1:NCOL) = t_lev(1:NCOL,iSFC) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) end subroutine GFS_rrtmgp_pre_run diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 8096aef2a..895bbc630 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -239,6 +239,15 @@ kind = kind_phys intent = in optional = F +[maxGPtemp] + standard_name = maximum_temperature_in_RRTMGP + long_name = maximum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/dcyc2.f b/physics/dcyc2.f index a3d7cf193..4678efa0b 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -178,7 +178,7 @@ subroutine dcyc2t3_run & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & - & dry, icy, wet, & + & dry, icy, wet, minGPtemp, maxGPtemp, & & minGPpres, use_LW_jacobian, sfculw, fluxlwUP_jac, & & t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, flux2D_lwDOWN, & & pert_radtend, do_sppt,ca_global, & @@ -216,7 +216,8 @@ subroutine dcyc2t3_run & logical, intent(in) :: use_LW_jacobian, pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres + & deltim, fhswr, minGPpres, & + & minGPtemp, maxGPtemp real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & @@ -372,8 +373,8 @@ subroutine dcyc2t3_run & ! ! Compute temperatute at level interfaces. ! - call cmp_tlev(im, levs, minGPpres, p_lay, t_lay, p_lev, tsfc, & - & t_lev2) + call cmp_tlev(im, levs, minGPpres, minGPtemp, maxGPtemp, p_lay,& + & t_lay, p_lev, tsfc, t_lev2) ! ! Adjust up/downward fluxes (at layer interfaces). diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index a460db7ab..25b06cc83 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -353,6 +353,24 @@ type = logical intent = in optional = F +[minGPtemp] + standard_name = minimum_temperature_in_RRTMGP + long_name = minimum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[maxGPtemp] + standard_name = maximum_temperature_in_RRTMGP + long_name = maximum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [minGPpres] standard_name = minimum_pressure_in_RRTMGP long_name = minimum pressure allowed in RRTMGP diff --git a/physics/radiation_tools.F90 b/physics/radiation_tools.F90 index c6524aab6..a8d3f5457 100644 --- a/physics/radiation_tools.F90 +++ b/physics/radiation_tools.F90 @@ -2,20 +2,16 @@ module radiation_tools use machine, only: & kind_phys ! Working type implicit none - - real(kind_phys) :: & - rrtmgp_minP, & ! Minimum pressure allowed in RRTMGP - rrtmgp_minT ! Minimum temperature allowed in RRTMGP contains ! ######################################################################################### ! ######################################################################################### - subroutine cmp_tlev(nCol,nLev,minP,p_lay,t_lay,p_lev,tsfc,t_lev) + subroutine cmp_tlev(nCol,nLev,minP,minT,maxT,p_lay,t_lay,p_lev,tsfc,t_lev) ! Inputs integer, intent(in) :: & nCol,nLev real(kind_phys),intent(in) :: & - minP + minP,minT,maxT real(kind_phys),dimension(nCol),intent(in) :: & tsfc real(kind_phys),dimension(nCol,nLev),intent(in) :: & @@ -78,6 +74,18 @@ subroutine cmp_tlev(nCol,nLev,minP,p_lay,t_lay,p_lev,tsfc,t_lev) t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) endif + ! Bound temperature at layer interfaces + do iCol=1,NCOL + do iLay=1,nLev+1 + if (t_lev(iCol,iLay) .le. minT) then + t_lev(iCol,iLay) = minT + epsilon(minT) + endif + if (t_lev(iCol,iLay) .ge. maxT) then + t_lev(iCol,iLay) = maxT - epsilon(maxT) + endif + enddo + enddo + end subroutine cmp_tlev ! ######################################################################################### diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index a116ad772..d7201e026 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -76,7 +76,7 @@ module rrtmgp_lw_gas_optics !! \htmlinclude rrtmgp_lw_gas_optics_init.html !! subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, & - mpirank, mpiroot, gas_concentrations, minGPpres, minGPtemp, errmsg, errflg) + mpirank, mpiroot, gas_concentrations, minGPpres, minGPtemp, maxGPtemp, errmsg, errflg) ! Inputs type(ty_gas_concs), intent(inout) :: & @@ -96,6 +96,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom errflg ! CCPP error code real(kind_phys), intent(out) :: & minGPtemp, & ! Minimum temperature allowed by RRTMGP. + maxGPtemp, & ! Maximum temperature allowed by RRTMG. minGPpres ! Minimum pressure allowed by RRTMGP. ! Local variables @@ -450,6 +451,7 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom ! temperature (GFS_rrtmgp_pre.F90) minGPpres = lw_gas_props%get_press_min() minGPtemp = lw_gas_props%get_temp_min() + maxGPtemp = lw_gas_props%get_temp_max() end subroutine rrtmgp_lw_gas_optics_init diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index c92567e14..823501cfa 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -92,6 +92,15 @@ kind = kind_phys intent = out optional = F +[maxGPtemp] + standard_name = maximum_temperature_in_RRTMGP + long_name = maximum temperature allowed in RRTMGP + units = K + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F ######################################################################## [ccpp-arg-table] From 04b562461895b60b3e4b5761ec1ab57d891f1d5a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 May 2021 20:35:15 -0400 Subject: [PATCH 053/165] removing some blanks --- physics/aerinterp.F90 | 2 +- physics/sfc_sice.f | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index f59405e72..dbcf73603 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -330,7 +330,7 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & !$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & !$OMP shared(aerpm,aerpres,aerout,n1,n2,lev,nthrds) & !$OMP shared(temij,temiy,temjx,ddxy) & -!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem) & +!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem) & !$OMP copyin(tx1,tx2) firstprivate(tx1,tx2) !$OMP do diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 009b5f228..46675fd3d 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -60,7 +60,7 @@ subroutine sfc_sice_run & ! ! ! call sfc_sice ! ! inputs: ! -! ( im, kice, ps, t1, q1, delt, ! +! ( im, kice, ps, t1, q1, delt, ! ! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! ! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! ! flag_iter, ! @@ -71,8 +71,8 @@ subroutine sfc_sice_run & ! ! ! subprogram called: ice3lay. ! ! ! -!> program history log: -!!- 2005 -- xingren wu created from original progtm and added +!> program history log: +!!- 2005 -- xingren wu created from original progtm and added !! two-layer ice model !!- 200x -- sarah lu added flag_iter !!- oct 2006 -- h. wei added cmm and chh to output From aff96dda201d4309b3b2a9def09b96c99ce2c70e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 May 2021 21:18:04 -0400 Subject: [PATCH 054/165] removing some blanks in sfcsub --- physics/sfcsub.F | 70 ++++++++++++++++++++++++------------------------ 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 5de649571..0a8ab10e6 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -25,7 +25,7 @@ module sfccyc_module & kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, & 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, + & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, & kpdvet=225, kpdsot=224,kpdabs_1=159, & kpdsnd=66 ) ! @@ -54,11 +54,11 @@ end function message end module sfccyc_module !>\ingroup mod_GFS_phys_time_vary -!! This subroutine reads or interpolates surface climatology data in analysis +!! 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 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. @@ -317,7 +317,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx +!clu [-1l/+1l] relax tsfsmx parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, & tsfjmx=273.16,tsfjmn=173.0) @@ -343,19 +343,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & 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) + & 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) + & 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.) + & 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) + & 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., @@ -468,7 +468,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & &, fnvegc,fnvetc,fnsotc & - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 + &, 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) & @@ -484,7 +484,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & &, fnvega,fnveta,fnsota & - &, fnvmna,fnvmxa,fnslpa,fnabsa + &, fnvmna,fnvmxa,fnslpa,fnabsa ! real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & &, zoranl(len), albanl(len,4), aisanl(len) & @@ -1397,13 +1397,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & vetanl,sotanl,alfanl, & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, + & 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, + & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) ! ! reverse scaling to match with grib analysis input @@ -1436,15 +1436,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & tg3anl,cvanl ,cvbanl,cvtanl, & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & vetanl,sotanl,alfanl,tsfan0, - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & kpdvet,kpdsot,kpdalf, - & kpdvmn,kpdvmx,kpdslp,kpdabs, + & kpdvmn,kpdvmx,kpdslp,kpdabs, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & irtvet,irtsot,irtalf - &, irtvmn,irtvmx,irtslp,irtabs, + &, irtvmn,irtvmx,irtslp,irtabs, & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk &, me, lanom) @@ -1781,7 +1781,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !cwu [+1l] add ()anl for sih, sic & sihanl,sicanl, !clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, @@ -2029,13 +2029,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & slmskl,slmskw,sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, + & 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, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, & cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,veganl, @@ -2048,7 +2048,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, + & irtvmn,irtvmx,irtslp,irtabs, & irtvet,irtsot,irtalf,landice,me) call setzro(snoanl,epssno,len) @@ -2063,7 +2063,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, !cwu [+1l] add sihnew, aislim, sihanl & sicanl - & 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 @@ -3623,7 +3623,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & 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) + &, 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), & @@ -3659,7 +3659,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & 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 + vmxanl(i) = vmxclm(i) ! max vegetation cover slpanl(i) = slpclm(i) ! slope type absanl(i) = absclm(i) ! max snow albedo enddo @@ -4373,7 +4373,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & slifcs(len),vegfcs(len), & & vetfcs(len),sotfcs(len),alffcs(len,2) & &, sihfcs(len),sicfcs(len) & - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(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), & @@ -6294,7 +6294,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6309,7 +6309,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6324,7 +6324,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6339,7 +6339,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6517,9 +6517,9 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & ! 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 + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo enddo crit=0.1 call rof01(rslmsk,ijmax,'gt',crit) @@ -6580,7 +6580,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -8406,8 +8406,8 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & 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(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 @@ -8439,7 +8439,7 @@ subroutine fixrda(lugb,fngrib,kpds5,slmask, & 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 + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! From d4fe665917165d72b82309d4d0dde30537d5cf2d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 11 May 2021 12:45:09 -0400 Subject: [PATCH 055/165] updating to include separate logicvals lake and use_flake, the latter meaing using flake model for lake --- physics/GFS_surface_composites.F90 | 20 +++++++++++--------- physics/GFS_surface_composites.meta | 10 +++++++++- physics/flake_driver.meta | 4 ++-- physics/sfc_nst.f | 10 +++++----- physics/sfc_nst.meta | 16 ++++------------ physics/sfc_ocean.F | 8 ++++---- physics/sfc_ocean.meta | 2 +- physics/sfc_sice.f | 24 +++++------------------- physics/sfc_sice.meta | 8 ++++---- 9 files changed, 45 insertions(+), 57 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 3f23775f8..05eac8c01 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -27,7 +27,7 @@ end subroutine GFS_surface_composites_pre_finalize !! \htmlinclude GFS_surface_composites_pre_run.html !! subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, dry, icy, use_flake, ocean, wet, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, dry, icy, lake, use_flake, ocean, wet, & hice, cice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & @@ -42,7 +42,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx integer, intent(in ) :: im, lkm logical, intent(in ) :: frac_grid, cplflx, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, use_flake, ocean, wet + logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, ocean, wet real(kind=kind_phys), dimension(:), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac real(kind=kind_phys), dimension(:), intent(inout) :: cice, hice real(kind=kind_phys), dimension(:), intent( out) :: frland @@ -240,14 +240,16 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! to prepare to separate lake from ocean under water category do i = 1, im - if(wet(i) .and. lkm == 1) then - if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif + if(wet(i) .and. lakefrac(i) > zero) then + lake(i) = .true. + if (lkm == 1 .and. lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then + use_flake(i) = .true. + else + use_flake(i) = .false. + endif else - use_flake(i) = .false. + lake(i) = .false. + use_flake(i) = .false. endif enddo ! diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 996fb54aa..2a54d5ea9 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -116,7 +116,7 @@ type = logical intent = inout optional = F -[use_flake] +[lake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag @@ -124,6 +124,14 @@ type = logical intent = inout optional = F +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = inout + optional = F [ocean] standard_name = flag_nonzero_ocean_surface_fraction long_name = flag indicating presence of some ocean surface area fraction diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 74fb6b7e6..b160dd7de 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -132,8 +132,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 31d75cffa..964f21d14 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -94,7 +94,7 @@ subroutine sfc_nst_run & ! prsik1 - real, im ! ! prslk1 - real, im ! ! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_flake - logical, =T if any lake otherwise ocn +! use_flake- logical, =T if flake model is used for lake im ! ! icy - logical, =T if any ice im ! ! xlon - real, longitude (radians) im ! ! sinlat - real, sin of latitude im ! @@ -676,7 +676,7 @@ end subroutine sfc_nst_pre_finalize !> \section NSST_general_pre_algorithm General Algorithm !! @{ subroutine sfc_nst_pre_run - & (im, wet, use_flake, tgice, tsfco, tsurf_wat, + & (im, wet, tgice, tsfco, tsurf_wat, & tseal, xt, xz, dt_cool, z_c, tref, cplflx, & oceanfrac, nthreads, errmsg, errflg) @@ -689,7 +689,7 @@ subroutine sfc_nst_pre_run ! --- inputs: integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet, use_flake + logical, dimension(:), intent(in) :: wet real (kind=kind_phys), intent(in) :: tgice real (kind=kind_phys), dimension(:), intent(in) :: & tsfco, xt, xz, dt_cool, z_c, oceanfrac @@ -717,7 +717,7 @@ subroutine sfc_nst_pre_run errflg = 0 do i=1,im - if (wet(i) .and. .not. use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > 0.0) then ! tem = (oro(i)-oro_uf(i)) * rlapse ! DH* 20190927 simplyfing this code because tem is zero !tem = zero @@ -735,7 +735,7 @@ subroutine sfc_nst_pre_run call get_dtzm_2d (xt, xz, dt_cool, & & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) do i=1,im - if (wet(i) .and. oceanfrac(i)>zero .and..not.use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > zero ) then ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index d01c2bc0a..df2ad766b 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -240,8 +240,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical @@ -688,14 +688,6 @@ type = logical intent = in optional = F -[use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F [tgice] standard_name = freezing_point_temperature_of_seawater long_name = freezing point temperature of seawater @@ -873,8 +865,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 67a6df04f..e5f8f8e68 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -27,7 +27,7 @@ subroutine sfc_ocean_run & !................................... ! --- inputs: & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & - & tskin, cm, ch, prsl1, prslki, wet, use_flake, wind, &, ! --- inputs + & tskin, cm, ch, prsl1, prslki, wet, lake, wind, &, ! --- inputs & flag_iter, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -42,7 +42,7 @@ subroutine sfc_ocean_run & ! inputs: ! ! ( im, ps, t1, q1, tskin, cm, ch, ! !! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! -! prsl1, prslki, wet, use_flake, wind, flag_iter, ! +! prsl1, prslki, wet, lake, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! ! ! @@ -102,7 +102,7 @@ subroutine sfc_ocean_run & real (kind=kind_phys), dimension(:), intent(in) :: ps, & & t1, q1, tskin, cm, ch, prsl1, prslki, wind - logical, dimension(:), intent(in) :: flag_iter, wet, use_flake + logical, dimension(:), intent(in) :: flag_iter, wet, lake ! --- outputs: real (kind=kind_phys), dimension(:), intent(inout) :: qsurf, & @@ -130,7 +130,7 @@ subroutine sfc_ocean_run & ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface - if (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) then + if (wet(i) .and. flag_iter(i) .and. .not. lake(i)) then q0 = max( q1(i), qmin ) rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f27c2207d..6fdfa0555 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -131,7 +131,7 @@ type = logical intent = in optional = F -[use_flake] +[lake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 46675fd3d..5e18828b2 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -48,8 +48,7 @@ subroutine sfc_sice_run & & flag_iter, use_flake, lprnt, ipr, me, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & - & islmsk_cice, & -! & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & + & islmsk, & & errmsg, errflg & ) @@ -161,13 +160,9 @@ subroutine sfc_sice_run & real (kind=kind_phys), dimension(:), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & & prsl1, prslki, prsik1, prslk1, wind -! & prsl1, prslki, prsik1, prslk1, wind, oceanfrac -! integer, dimension(im), intent(in) :: islimsk - integer, dimension(:), intent(in) :: islmsk_cice + integer, dimension(:), intent(in) :: islmsk real (kind=kind_phys), intent(in) :: delt -! real (kind=kind_phys), intent(in) :: delt, min_seaice, & -! & min_lakeice logical, dimension(im), intent(in) :: flag_iter, use_flake @@ -215,11 +210,10 @@ subroutine sfc_sice_run & do_sice = .false. do i = 1, im -! flag(i) = islmsk_cice(i) == 2 .and. flag_iter(i) - flag(i) = islmsk_cice(i) == 2 .and. flag_iter(i) & - & .and. .not. use_flake(i) + flag(i) = islmsk(i) == 2 .and. flag_iter(i) & + & .and. .not. use_flake(i) do_sice = do_sice .or. flag(i) -! if (flag_iter(i) .and. islmsk_cice(i) < 2) then +! if (flag_iter(i) .and. islmsk(i) < 2) then ! hice(i) = zero ! fice(i) = zero ! endif @@ -253,19 +247,11 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then -! if (oceanfrac(i) > zero) then -! cimin = min_seaice -! else -! cimin = min_lakeice -! endif -! psurf(i) = 1000.0 * ps(i) -! ps1(i) = 1000.0 * prsl1(i) ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) q0 = max(q1(i), qmin) -! tsurf(i) = tskin(i) #ifdef GSD_SURFACE_FLUXES_BUGFIX theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer #else diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index a378cc379..ff58b1e8a 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -266,12 +266,12 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical - intent = inout + intent = in optional = F [lprnt] standard_name = flag_print @@ -441,7 +441,7 @@ kind = kind_phys intent = inout optional = F -[islmsk_cice] +[islmsk] standard_name = sea_land_ice_mask_cice long_name = sea/land/ice mask cice (=0/1/2) units = flag From 6ebe85ef4a4d51a8e8bf7921e8079d395f90d89a Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 11 May 2021 18:40:02 +0000 Subject: [PATCH 056/165] Apply constant heating-rate adjustment above 100hPa --- physics/dcyc2.f | 71 ++++++++++++++++++++++++++++++------------------- 1 file changed, 44 insertions(+), 27 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 4678efa0b..368272ff1 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -254,11 +254,19 @@ subroutine dcyc2t3_run & integer, intent(out) :: errflg ! --- locals: - integer :: i, k, nstp, nstl, it, istsun(im),iSFC + integer :: i, k, nstp, nstl, it, istsun(im),iSFC,iTOA real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 + real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,c1,c2,c3,c4,c5,ku + ! Pressure limit for LW flux adjustment + real(kind=kind_phys), parameter :: & + & plim_fluxAdj_upper = 10000. + ! Scaling factor for downwelling LW Jacobian profile. + real(kind=kind_phys), parameter :: & + & c0 = 0.2 + logical :: init_lev ! !===> ... begin here ! @@ -268,9 +276,11 @@ subroutine dcyc2t3_run & ! Vertical ordering? if (p_lev(1,1) .lt. p_lev(1, levs)) then - iSFC = levs + iSFC = levs + 1 + iTOA = 1 else iSFC = 1 + iTOA = levs + 1 endif tem1 = fhswr / deltim @@ -376,34 +386,41 @@ subroutine dcyc2t3_run & call cmp_tlev(im, levs, minGPpres, minGPtemp, maxGPtemp, p_lay,& & t_lay, p_lev, tsfc, t_lev2) + ! Compute adjusted net LW flux foillowing Hogan and Bozzo 2015 (10.1002/2015MS000455) + ! Here we assume that the profile of the downwelling LW Jaconiam has the same shape + ! as the upwelling, but scaled and offset. + ! The scaling factor is 0.2 + ! The profile of the downwelling Jacobian (J) is offset so that + ! J_dn_sfc / J_up_sfc = scaling_factor + ! J_dn_toa / J_up_sfc = 0 ! - ! Adjust up/downward fluxes (at layer interfaces). - ! - do k = 1, levs+1 - do i = 1, im - flxlwup_adj(i,k) = flux2D_lwUP(i,k) - if (p_lev(i,k) .gt. 10000.) then - dT = t_lev2(i,k) - t_lev(i,k) - flxlwup_adj(i,k) = flux2D_lwUP(i,k) + & - & fluxlwUP_jac(i,k)*dT + do i = 1, im + c1 = fluxlwUP_jac(i,iSFC) + c2 = fluxlwUP_jac(i,iTOA) / c1 + c3 = t_lev2(i,iSFC) - t_lev(i,iSFC) + init_lev = .true. + do k = 1, levs + ! Only apply the Jacobian adjustment below plim_fluxAdj_upper + if (p_lev(i,k) .gt. plim_fluxAdj_upper) then + c4 = fluxlwUP_jac(i,k)/c1 + fluxlwnet = (flux2D_lwUP(i,k+1) - flux2D_lwUP(i,k) -& + & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) + ! (Eq. 9) + c5 = c0 * (c4 - c2) / (1 - c2) + ! (Eq. 10) + fluxlwnet_adj = fluxlwnet + c3*(c4-c5) + ! Compute adjusted heating rate + htrlw(i,k) = fluxlwnet_adj * con_g / & + & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) + + ! Store vertical index for plim_fluxAdj_upper + ku = k + ! Above, offset the heating rate by he same amount as in plim_fluxAdj_upper + else + htrlw(i,k) = hlw(i,k) + (htrlw(i,ku)-hlw(i,ku)) endif - enddo - enddo - ! - ! Compute new heating rate (within each layer). - ! - do k = 1, levs - htrlw(1:im,k) = & - & (flxlwup_adj(1:im,k+1) - flxlwup_adj(1:im,k) - & - & flux2D_lwDOWN(1:im,k+1) + flux2D_lwDOWN(1:im,k)) * & - & con_g / (con_cp * (p_lev(1:im,k+1) - p_lev(1:im,k))) - enddo - ! - ! Add radiative heating rates to physics heating rate - ! - do k = 1, levs - do i = 1, im + ! Add radiative heating rates to physics heating rate dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k) enddo enddo From 230d479e58cb380de9d24e8b67778db468250ba3 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 11 May 2021 19:47:23 +0000 Subject: [PATCH 057/165] Add vetical decay to impact of flux adjustment above threshold. --- physics/dcyc2.f | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 368272ff1..f671cf1f2 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -266,7 +266,6 @@ subroutine dcyc2t3_run & ! Scaling factor for downwelling LW Jacobian profile. real(kind=kind_phys), parameter :: & & c0 = 0.2 - logical :: init_lev ! !===> ... begin here ! @@ -398,7 +397,6 @@ subroutine dcyc2t3_run & c1 = fluxlwUP_jac(i,iSFC) c2 = fluxlwUP_jac(i,iTOA) / c1 c3 = t_lev2(i,iSFC) - t_lev(i,iSFC) - init_lev = .true. do k = 1, levs ! Only apply the Jacobian adjustment below plim_fluxAdj_upper if (p_lev(i,k) .gt. plim_fluxAdj_upper) then @@ -417,7 +415,8 @@ subroutine dcyc2t3_run & ku = k ! Above, offset the heating rate by he same amount as in plim_fluxAdj_upper else - htrlw(i,k) = hlw(i,k) + (htrlw(i,ku)-hlw(i,ku)) + htrlw(i,k) = hlw(i,k)+(p_lev(i,k)/plim_fluxAdj_upper)*& + & (htrlw(i,ku)-hlw(i,ku)) endif ! Add radiative heating rates to physics heating rate From 71d019c934978921f575b8ef2e9059a3b4457775 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 14 May 2021 21:13:04 -0400 Subject: [PATCH 058/165] creating a version without ncld --- physics/GFS_MP_generic.F90 | 6 +++--- physics/GFS_MP_generic.meta | 8 -------- physics/GFS_rrtmg_pre.F90 | 13 ++++--------- physics/GFS_rrtmg_pre.meta | 8 -------- physics/cs_conv.F90 | 4 ++-- physics/cs_conv.meta | 8 -------- physics/cs_conv_aw_adj.F90 | 4 ++-- physics/cs_conv_aw_adj.meta | 8 -------- physics/gfs_phy_tracer_config.F | 18 +++--------------- physics/samfdeepcnv.meta | 4 ++-- physics/samfshalcnv.meta | 4 ++-- physics/sascnvn.meta | 4 ++-- physics/shalcnv.meta | 4 ++-- 13 files changed, 22 insertions(+), 71 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 04450b612..680302cad 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,7 +85,7 @@ end subroutine GFS_MP_generic_post_init !! !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ - subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & + subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, con_g, dtf, frain, rainc, rain1, & rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, rain0, ice0, snow0, & graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & @@ -97,7 +97,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, implicit none - integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac + integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm @@ -373,7 +373,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, do i=1, im work1(i) = zero enddo - if (ncld > 0) then + if (nncl > 0) then do ic = ntcw, ntcw+nncl-1 do i=1,im work1(i) = work1(i) + gq0(i,k,ic) diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index fa4be3ea7..f6471dcb2 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -176,14 +176,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [nncl] standard_name = number_of_tracers_for_cloud_condensate long_name = number of tracers for cloud condensate diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 158067c05..dbea66985 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, imfdeepcnv_gf, me, ncnd, ntrac, num_p3d, npdf3d, ncnvcld3d,& - ntqv, ntcw,ntiw, ntlnc, ntinc, ncld, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -83,7 +83,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & imfdeepcnv, & imfdeepcnv_gf, me, ncnd, ntrac, & num_p3d, npdf3d, ncnvcld3d, ntqv, & - ntcw, ntiw, ntlnc, ntinc, ncld, & + ntcw, ntiw, ntlnc, ntinc, & ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -594,7 +594,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! call module_radiation_clouds::progcld1() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, !! call module_radiation_clouds::progcld3() -!! call module_radiation_clouds::progclduni() for unified cloud and ncld=2 +!! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -690,11 +690,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - -! else -! do j=1,ncld -! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount -! enddo endif do k=1,LMK do i=1,IM @@ -949,7 +944,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme ! or unified cloud and/or with MG microphysics - if (uni_cld .and. ncld >= 2) then + if (uni_cld .and. ncndl >= 2) then call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, & IM, LMK, LMP, cldcov, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 344befa97..d6da64ffb 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -161,14 +161,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntrw] standard_name = index_for_rain_water long_name = tracer index for rain water diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index d47dcd457..8ed33f0d3 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -13,7 +13,7 @@ end subroutine cs_conv_pre_finalize !! \section arg_table_cs_conv_pre_run Argument Table !! \htmlinclude cs_conv_pre_run.html !! - subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & + subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & & work1, work2, cs_parm1, cs_parm2, wcbmax, & & fswtr, fscav, save_q1, save_q2, save_q3, & & errmsg, errflg) @@ -24,7 +24,7 @@ subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & implicit none ! --- inputs - integer, intent(in) :: im, levs, ntrac, ncld + integer, intent(in) :: im, levs, ntrac real(kind_phys), dimension(:,:), intent(in) :: q real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 real(kind_phys), dimension(:), intent(in) :: work1, work2 diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 14a0d5bf2..5766cc3c2 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -31,14 +31,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [q] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity updated by physics diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 index 74cac9184..4b54290bd 100644 --- a/physics/cs_conv_aw_adj.F90 +++ b/physics/cs_conv_aw_adj.F90 @@ -27,7 +27,7 @@ end subroutine cs_conv_aw_adj_finalize !! !\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, & + ntrac, ntcw, ntclamt, nncl, con_g, sigmafrac, & gt0, gq0, save_t, save_q, prsi, cldfrac, subcldfrac, & prcp, imp_physics, imp_physics_mg, errmsg, errflg) @@ -38,7 +38,7 @@ subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & ! --- interface variables integer, intent(in) :: im, levs logical, intent(in) :: do_cscnv, do_aw, do_shoc - integer, intent(in) :: ntrac, ncld, ntcw, ntclamt, nncl + integer, intent(in) :: ntrac, ntcw, ntclamt, nncl real(kind_phys), intent(in) :: con_g real(kind_phys), dimension(:,:), intent(inout) :: sigmafrac real(kind_phys), dimension(:,:), intent(inout) :: gt0 diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index 720330c50..8c58b28f1 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -55,14 +55,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntcw] standard_name = index_for_liquid_cloud_condensate long_name = tracer index for cloud condensate (or liquid water) diff --git a/physics/gfs_phy_tracer_config.F b/physics/gfs_phy_tracer_config.F index 8ed7443d3..0e1185a50 100644 --- a/physics/gfs_phy_tracer_config.F +++ b/physics/gfs_phy_tracer_config.F @@ -66,7 +66,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, c implicit none ! input - integer, intent(in) :: me, ntoz,ntcw,ncld,ntke, + integer, intent(in) :: me, ntoz,ntcw,ntke, & ntiw,ntlnc,ntinc,nto,nto2, & fprcp,ntrw,ntsw,ntrnc,ntsnc ! output @@ -83,19 +83,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, ! initialize chem tracers call gocart_tracer_config(me) -! call gocart_tracer_config(gfs_phy_tracer,me) - -! ntrac_met = number of met tracers -!hmhj if ( ntoz < ntcw ) then -!hmhj gfs_phy_tracer%ntrac_met = ntcw + ncld - 1 -!hmhj else -!hmhj gfs_phy_tracer%ntrac_met = ntoz -!hmhj endif -!hmhj if ( gfs_phy_tracer%ntrac_met /= ntrac ) then -!hmhj print *,'LU_TRC: ERROR ! inconsistency in ntrac:', -!hmhj& ntrac, gfs_phy_tracer%ntrac_met -!hmhj stop 222 -!hmhj endif + ! input ntrac is meteorological tracers gfs_phy_tracer%ntrac_met = ntrac @@ -230,7 +218,7 @@ subroutine fixchar(name_in, name_out, option) endif enddo - name_out=trim(name_out) + name_out = trim(name_out) return end subroutine fixchar diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 802aeb50a..9ff880d78 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -330,8 +330,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate units = count dimensions = () type = integer diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 7f5421b70..beab2b690 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -313,8 +313,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate units = count dimensions = () type = integer diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index af25b8477..783a78400 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -327,8 +327,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate units = count dimensions = () type = integer diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 7986d28f8..699ed9374 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -334,8 +334,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_tracers_for_cloud_condensate + long_name = number of tracers for cloud condensate units = count dimensions = () type = integer From 6c912aa910621e1a9c6429505a5f8ea990b43ec6 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 18 May 2021 19:05:07 -0400 Subject: [PATCH 059/165] removing Interstitial%nncl and replacing Model%ncnd --- physics/GFS_MP_generic.meta | 8 ++++---- physics/cs_conv_aw_adj.meta | 4 ++-- physics/moninshoc.meta | 4 ++-- physics/samfdeepcnv.meta | 4 ++-- physics/samfshalcnv.meta | 4 ++-- physics/sascnvn.meta | 4 ++-- physics/shalcnv.meta | 4 ++-- 7 files changed, 16 insertions(+), 16 deletions(-) diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index f6471dcb2..468bd1397 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -56,8 +56,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -177,8 +177,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index 8c58b28f1..b0b8e6244 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -72,8 +72,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index 5cff902d7..da79592fe 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -40,8 +40,8 @@ intent = in optional = F [ncnd] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 9ff880d78..3e9548ae9 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -330,8 +330,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index beab2b690..143d419ae 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -313,8 +313,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index 783a78400..89f2c6984 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -327,8 +327,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 699ed9374..38436c8bd 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -334,8 +334,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer From f20e19608466b2cbbac5e930f49f49a2fb38fae5 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Wed, 19 May 2021 14:53:11 +0000 Subject: [PATCH 060/165] add dtp,pratemax,rain to meta to compute hourly max precip rate in mm/hr --- physics/maximum_hourly_diagnostics.F90 | 8 +++++++- physics/maximum_hourly_diagnostics.meta | 27 +++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 615c49bed..1486ac027 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -30,7 +30,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, imp_physics_fer_hires,con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & - t02min, rh02max, rh02min, errmsg, errflg) + t02min, rh02max, rh02min, dtp, rain, pratemax, & + errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs @@ -54,6 +55,9 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, real(kind_phys), intent(inout) :: t02min(:) real(kind_phys), intent(inout) :: rh02max(:) real(kind_phys), intent(inout) :: rh02min(:) + real(kind_phys), intent(in ) :: dtp + real(kind_phys), intent(in ) :: rain(im) + real(kind_phys), intent(inout) :: pratemax(im) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -96,6 +100,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, t02min(i) = 999. rh02max(i) = -999. rh02min(i) = 999. + pratemax(i) = 0. enddo endif do i=1,im @@ -119,6 +124,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, rh02min(i) = min(rh02min(i),rh02) t02max(i) = max(t02max(i),t2m(i)) !<--- hourly max 2m t t02min(i) = min(t02min(i),t2m(i)) !<--- hourly min 2m t + pratemax(i) = max(pratemax(i),(3.6E6/dtp)*rain(i)) enddo end subroutine maximum_hourly_diagnostics_run diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 67b3df039..0f87c86af 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -233,6 +233,33 @@ kind = kind_phys intent = inout optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[pratemax] + standard_name = maximum_precipitation_rate_over_maximum_hourly_time_interval + long_name = maximum precipitation rate over maximum hourly time interval + units = mm h-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From c6416fe4bb67d2f4a82331668bfbbd0dfe7b212f Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Thu, 20 May 2021 04:42:11 +0000 Subject: [PATCH 061/165] Remove legacy code used for coupling with GSDCHEM. --- physics/GFS_DCNV_generic.F90 | 8 +------- physics/GFS_DCNV_generic.meta | 9 --------- physics/GFS_PBL_generic.F90 | 11 +++-------- physics/GFS_PBL_generic.meta | 26 -------------------------- physics/GFS_SCNV_generic.F90 | 14 ++------------ physics/GFS_SCNV_generic.meta | 9 --------- physics/GFS_debug.F90 | 9 ++------- physics/GFS_suite_interstitial.F90 | 18 +++--------------- physics/GFS_suite_interstitial.meta | 17 ----------------- physics/GFS_surface_generic.F90 | 6 +++--- physics/GFS_surface_generic.meta | 6 +++--- physics/gfdl_cloud_microphys.F90 | 8 ++++---- physics/gfdl_cloud_microphys.meta | 6 +++--- 13 files changed, 24 insertions(+), 123 deletions(-) diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index 6c214813b..7a3942888 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -17,7 +17,7 @@ end subroutine GFS_DCNV_generic_pre_finalize !! subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm,& gu0, gv0, gt0, gq0_water_vapor, & - save_u, save_v, save_t, save_qv, dqdti, & + save_u, save_v, save_t, save_qv, & errmsg, errflg) use machine, only: kind_phys @@ -34,8 +34,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:), intent(inout) :: save_qv - ! dqdti only allocated if cplchm is .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -70,10 +68,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc enddo endif - if (cplchm) then - dqdti = zero - endif - end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index ff7933f07..819608ae8 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -127,15 +127,6 @@ kind = kind_phys intent = inout optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index f5eda444f..09576443c 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -83,7 +83,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, & ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef, trans_aero, ntchs, ntchm, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, cplchm, ltaerosol, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & hybedmf, do_shoc, satmedmf, qgrs, vdftra, save_u, save_v, save_t, save_q, & ldiag3d, qdiag3d, lssav, ugrs, vgrs, tgrs, errmsg, errflg) @@ -99,7 +99,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, logical, intent(in) :: trans_aero, ldiag3d, qdiag3d, lssav integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6 integer, intent(in) :: imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires - logical, intent(in) :: cplchm, ltaerosol, hybedmf, do_shoc, satmedmf + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -317,7 +317,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, & dq3dt_ozone, rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, hefac, & + dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, hefac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) use machine, only : kind_phys @@ -366,9 +366,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, dimension(:),intent(in) :: wet, dry, icy real(kind=kind_phys), dimension(:), intent(out) :: ushfsfci - real(kind=kind_phys), dimension(:,:), intent(inout) :: dkt_cpl - real(kind=kind_phys), dimension(:,:), intent(in) :: dkt - ! From canopy heat storage - reduction factors in latent/sensible heat flux due to surface roughness real(kind=kind_phys), dimension(:), intent(in) :: hffac, hefac @@ -600,8 +597,6 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ushfsfci(i) = cp * rho * hflx(i) end do end if - ! dkt_cpl has dimensions (1:im,1:levs), but dkt has (1:im,1:levs-1) - dkt_cpl(1:im,1:levs-1) = dkt(1:im,1:levs-1) end if !-------------------------------------------------------lssav if loop ---------- diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 01f5ec3ce..bbc45c15d 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -255,14 +255,6 @@ type = integer intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -1316,24 +1308,6 @@ kind = kind_phys intent = in optional = F -[dkt_cpl] - standard_name = instantaneous_atmosphere_heat_diffusivity - long_name = instantaneous atmospheric heat diffusivity - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dkt] - standard_name = atmosphere_heat_diffusivity - long_name = atmospheric heat diffusivity - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F [hffac] standard_name = surface_upward_sensible_heat_flux_reduction_factor long_name = surface upward sensible heat flux reduction factor from canopy heat storage diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 450f0e5a9..cfdf4b9f1 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -71,7 +71,7 @@ end subroutine GFS_SCNV_generic_post_finalize !! \htmlinclude GFS_SCNV_generic_post_run.html !! subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, cplchm, & - frain, gu0, gv0, gt0, gq0_water_vapor, save_u, save_v, save_t, save_qv, dqdti, du3dt, dv3dt, dt3dt, dq3dt, clw, & + frain, gu0, gv0, gt0, gq0_water_vapor, save_u, save_v, save_t, save_qv, du3dt, dv3dt, dt3dt, dq3dt, clw, & shcnvcw, rain1, npdf3d, num_p3d, ncnvcld3d, cnvc, cnvw, & rainc, cnvprcp, cnvprcpb, cnvw_phy_f3d, cnvc_phy_f3d, & flag_for_scnv_generic_tend, & @@ -87,8 +87,7 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, cpl real(kind=kind_phys), dimension(:, :), intent(in) :: gu0, gv0, gt0, gq0_water_vapor real(kind=kind_phys), dimension(:, :), intent(in) :: save_u, save_v, save_t, save_qv - ! dqdti, dt3dt, dq3dt, only allocated if ldiag3d == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + ! dt3dt, dq3dt, only allocated if ldiag3d == .true. real(kind=kind_phys), dimension(:,:), intent(inout) :: du3dt, dv3dt, dt3dt, dq3dt real(kind=kind_phys), dimension(:, :,:), intent(inout) :: clw @@ -154,15 +153,6 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, cpl endif endif endif -! - if (cplchm) then - do k=1,levs - do i=1,im - tem = (gq0_water_vapor(i,k)-save_qv(i,k)) * frain - dqdti(i,k) = dqdti(i,k) + tem - enddo - enddo - endif ! do k=1,levs do i=1,im diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index dea2f039c..19242cf6a 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -284,15 +284,6 @@ kind = kind_phys intent = in optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [du3dt] standard_name = cumulative_change_in_x_wind_due_to_shallow_convection long_name = cumulative change in x wind due to shallow convection diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 7e854b2b0..16e742306 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -807,13 +807,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, if (Model%cplchm) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%rainc_cpl', Coupling%rainc_cpl) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ushfsfci ', Coupling%ushfsfci ) - if (Model%cplgocart) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfi_lsan', Coupling%pfi_lsan ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfl_lsan', Coupling%pfl_lsan ) - else - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dkt ', Coupling%dkt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqdti ', Coupling%dqdti ) - endif + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfi_lsan', Coupling%pfi_lsan ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfl_lsan', Coupling%pfl_lsan ) end if if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sppt_wts', Coupling%sppt_wts) diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index fab26b494..35523484a 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -652,10 +652,10 @@ end subroutine GFS_suite_interstitial_4_finalize !> \section arg_table_GFS_suite_interstitial_4_run Argument Table !! \htmlinclude GFS_suite_interstitial_4_run.html !! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, & - gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, dqdti, errmsg, errflg) + gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, errmsg, errflg) use machine, only: kind_phys use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber @@ -668,7 +668,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in) :: ltaerosol, cplchm, convert_dry_rho + logical, intent(in) :: ltaerosol, convert_dry_rho real(kind=kind_phys), intent(in) :: con_pi, dtf real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc @@ -682,9 +682,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(im,levs), intent(in) :: spechum - ! dqdti may not be allocated - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys character(len=*), intent(out) :: errmsg @@ -808,15 +805,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to enddo endif ! end if_ntcw -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (cplchm) then - do k=1,levs - do i=1,im - dqdti(i,k) = dqdti(i,k) * (one / dtf) - enddo - enddo - endif - end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index bdcc8f275..518b6d366 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1610,14 +1610,6 @@ type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [tracers_total] standard_name = number_of_total_tracers long_name = total number of tracers @@ -1886,15 +1878,6 @@ kind = kind_phys intent = inout optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 733ea2b17..1c4854bb0 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -210,7 +210,7 @@ end subroutine GFS_surface_generic_post_finalize !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplgocart, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& + subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & @@ -222,7 +222,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplgocart, cplwav, lssav, i implicit none integer, intent(in) :: im - logical, intent(in) :: cplflx, cplgocart, cplwav, lssav + logical, intent(in) :: cplflx, cplchm, cplwav, lssav logical, dimension(im), intent(in) :: icy, wet real(kind=kind_phys), intent(in) :: dtf @@ -275,7 +275,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplgocart, cplwav, lssav, i v1(i) = vgrs_1(i) enddo - if (cplflx .or. cplgocart .or. cplwav) then + if (cplflx .or. cplchm .or. cplwav) then do i=1,im u10mi_cpl(i) = u10m(i) v10mi_cpl(i) = v10m(i) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 31b735dcd..59e3e40b6 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -497,9 +497,9 @@ type = logical intent = in optional = F -[cplgocart] - standard_name = flag_for_gocart_coupling - long_name = flag controlling gocart collection (default off) +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) units = flag dimensions = () type = logical diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 4c382d607..fd9a23489 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -119,7 +119,7 @@ subroutine gfdl_cloud_microphys_run( & rain0, ice0, snow0, graupel0, prcp0, sr, & dtp, hydrostatic, phys_hydrostatic, lradar, refl_10cm, & reset, effr_in, rew, rei, rer, res, reg, & - cplgocart, pfi_lsan, pfl_lsan, errmsg, errflg) + cplchm, pfi_lsan, pfl_lsan, errmsg, errflg) use machine, only: kind_phys @@ -159,8 +159,8 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), intent(inout), dimension(:,:) :: refl_10cm logical, intent (in) :: reset, effr_in real(kind=kind_phys), intent(inout), dimension(:,:) :: rew, rei, rer, res, reg - logical, intent (in) :: cplgocart - ! ice and liquid water 3d precipitation fluxes - only allocated if cplgocart is .true. + logical, intent (in) :: cplchm + ! ice and liquid water 3d precipitation fluxes - only allocated if cplchm is .true. real(kind=kind_phys), intent(inout), dimension(:,:) :: pfi_lsan, pfl_lsan character(len=*), intent(out) :: errmsg @@ -299,7 +299,7 @@ subroutine gfdl_cloud_microphys_run( & enddo ! output ice and liquid water 3d precipitation fluxes if requested - if (cplgocart) then + if (cplchm) then do k=1,levs kk = levs-k+1 do i=1,im diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 83095a34f..e2a5a5292 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -486,9 +486,9 @@ kind = kind_phys intent = inout optional = F -[cplgocart] - standard_name = flag_for_gocart_coupling - long_name = flag controlling gocart collection (default off) +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) units = flag dimensions = () type = logical From 3307baa8827bad76efa7597f910e835110015e7d Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 15:19:14 +0000 Subject: [PATCH 062/165] updated hfx2 & qfx2 --- physics/cu_gf_driver.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index 73ce19754..6d1315381 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -286,8 +286,8 @@ intent = in optional = F [hfx2] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -295,8 +295,8 @@ intent = in optional = F [qfx2] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real From 89cd97f87881a614f8d5d71162a66bbbf08667e2 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 15:24:46 +0000 Subject: [PATCH 063/165] updated evap & hfx --- physics/cu_ntiedtke.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/cu_ntiedtke.meta b/physics/cu_ntiedtke.meta index 4d4c6597a..235168f83 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/cu_ntiedtke.meta @@ -204,8 +204,8 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real @@ -213,8 +213,8 @@ intent = in optional = F [hfx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real From ccac8315af699a31f7462be7606baac1e24a5648 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 16:34:40 +0000 Subject: [PATCH 064/165] updated hflx & evap --- physics/gcm_shoc.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/gcm_shoc.meta b/physics/gcm_shoc.meta index b021fa306..f44560890 100644 --- a/physics/gcm_shoc.meta +++ b/physics/gcm_shoc.meta @@ -288,8 +288,8 @@ intent = in optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -297,7 +297,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From 51f2842b98ee6b9cbd06bdcbede1bcf4058cad4a Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 16:35:41 +0000 Subject: [PATCH 065/165] updated GFS debug --- physics/GFS_debug.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 99f36f077..57bc05ede 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1091,7 +1091,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_ice ', Interstitial%ep1d_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_land ', Interstitial%ep1d_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_water ', Interstitial%ep1d_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evapq ', Interstitial%evapq ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) @@ -1134,7 +1133,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx_water ', Interstitial%gflx_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcu ', Interstitial%gwdcu ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcv ', Interstitial%gwdcv ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hefac ', Interstitial%hefac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zvfun ', Interstitial%zvfun ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hffac ', Interstitial%hffac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflxq ', Interstitial%hflxq ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflx_ice ', Interstitial%hflx_ice ) From 662bb1f4821ebc5e389ca371af126e9349008081 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 16:40:55 +0000 Subject: [PATCH 066/165] updated GFS PBL generic --- physics/GFS_PBL_generic.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 5183836ec..403a68b35 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -317,7 +317,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, & dq3dt_ozone, rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, hefac, & + dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) use machine, only : kind_phys @@ -370,7 +370,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, real(kind=kind_phys), dimension(:,:), intent(in) :: dkt ! From canopy heat storage - reduction factors in latent/sensible heat flux due to surface roughness - real(kind=kind_phys), dimension(:), intent(in) :: hffac, hefac + real(kind=kind_phys), dimension(:), intent(in) :: hffac character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -556,7 +556,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, else !use PBL fluxes when CICE fluxes is unavailable dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) - dtsfci_cpl(i) = dtsfc1(i) + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) dqsfci_cpl(i) = dqsfc1(i) end if elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point @@ -575,7 +575,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) dtsfci_cpl(i) = dtsfc1(i)*hffac(i) - dqsfci_cpl(i) = dqsfc1(i)*hefac(i) + dqsfci_cpl(i) = dqsfc1(i) endif ! dusfc_cpl (i) = dusfc_cpl(i) + dusfci_cpl(i) * dtf @@ -601,7 +601,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dusfci_diag(i) = dusfc1(i) dvsfci_diag(i) = dvsfc1(i) dtsfci_diag(i) = dtsfc1(i)*hffac(i) - dqsfci_diag(i) = dqsfc1(i)*hefac(i) + dqsfci_diag(i) = dqsfc1(i) dtsfc_diag (i) = dtsfc_diag(i) + dtsfci_diag(i) * dtf dqsfc_diag (i) = dqsfc_diag(i) + dqsfci_diag(i) * dtf enddo From 0dcde4af5652493772e9f619a926566db3ee0457 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 16:45:25 +0000 Subject: [PATCH 067/165] updated GFS PBL generic meta --- physics/GFS_PBL_generic.meta | 9 --------- 1 file changed, 9 deletions(-) diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 01f5ec3ce..9ca84695c 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -1343,15 +1343,6 @@ kind = kind_phys intent = in optional = F -[hefac] - standard_name = surface_upward_latent_heat_flux_reduction_factor - long_name = surface upward latent heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [ugrs] standard_name = x_wind long_name = zonal wind From 989701b0a2d4e7ca273bb7b09adc113d63715bf4 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 16:52:11 +0000 Subject: [PATCH 068/165] updated GFS surface generic --- physics/GFS_surface_generic.F90 | 63 +++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 26 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 70a5b3541..5c52c6c04 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -216,12 +216,13 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & - nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & - runoff, srunoff, runof, drain, lheatstrg, z0fac, e0fac, zorl, hflx, evap, hflxq, evapq, hffac, hefac, errmsg, errflg) + nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, islmsk, sigmaf, & + runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zorl, hflx, evap, hflxq, zvfun, hffac, errmsg, errflg) implicit none integer, intent(in) :: im + integer, dimension(im), intent(in) :: islmsk logical, intent(in) :: cplflx, cplwav, lssav logical, dimension(:), intent(in) :: icy, wet real(kind=kind_phys), intent(in) :: dtf @@ -237,15 +238,15 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt evcwa, transa, sbsnoa, snowca, snohfa, ep real(kind=kind_phys), dimension(:), intent(inout) :: runoff, srunoff - real(kind=kind_phys), dimension(:), intent(in) :: drain, runof + real(kind=kind_phys), dimension(:), intent(in) :: drain, runof, sigmaf ! For canopy heat storage logical, intent(in) :: lheatstrg - real(kind=kind_phys), intent(in) :: z0fac, e0fac + real(kind=kind_phys), intent(in) :: h0facu, h0facs real(kind=kind_phys), dimension(:), intent(in) :: zorl real(kind=kind_phys), dimension(:), intent(in) :: hflx, evap - real(kind=kind_phys), dimension(:), intent(out) :: hflxq, evapq - real(kind=kind_phys), dimension(:), intent(out) :: hffac, hefac + real(kind=kind_phys), dimension(:), intent(out) :: hflxq + real(kind=kind_phys), dimension(:), intent(out) :: zvfun, hffac ! CCPP error handling variables character(len=*), intent(out) :: errmsg @@ -255,8 +256,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys ! Parameters for canopy heat storage parametrization - real(kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 - real(kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 + real(kind=kind_phys), parameter :: z0min=0.1, z0max=1.0 integer :: i real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl @@ -361,32 +361,43 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt enddo endif -! --- ... Boundary Layer and Free atmospheic turbulence parameterization ! -! in order to achieve heat storage within canopy layer, in the canopy heat -! storage parameterization the kinematic sensible and latent heat fluxes -! (hflx & evap) as surface boundary forcings to the pbl scheme are -! reduced as a function of surface roughness +! in order to achieve heat storage within canopy layer, in the canopy +! heat torage parameterization the kinematic sensible heat flux +! (hflx) as surface boundary forcing to the pbl scheme is +! reduced as a function of surface roughness & green vegetation +! fraction ! +! background diffusivity & background mixing length are also given by +! a function of surface roughness & green vegetation fraction +! + do i=1,im + if(islmsk(i) == 1) then + tem = 0.01 * zorl(i) ! change unit from cm to m + tem1 = (tem - z0min) / (z0max - z0min) + tem1 = min(max(tem1, 0.0), 1.0) + tem2 = max(sigmaf(i), 0.1) +! tem2 = sigmaf(i) + zvfun(i) = sqrt(tem1 * tem2) + else + zvfun(i) = 0. + endif + enddo do i=1,im hflxq(i) = hflx(i) - evapq(i) = evap(i) hffac(i) = 1.0 - hefac(i) = 1.0 enddo if (lheatstrg) then do i=1,im - tem = 0.01 * zorl(i) ! change unit from cm to m - tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) - hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + e0fac * hffac(i) - hffac(i) = 1. + hffac(i) - hflxq(i) = hflx(i) / hffac(i) - evapq(i) = evap(i) / hefac(i) + if(islmsk(i) == 1) then + if(hflx(i) > 0.) then + hffac(i) = h0facu * zvfun(i) + else + hffac(i) = h0facs * zvfun(i) + endif + hffac(i) = 1. + hffac(i) + hflxq(i) = hflx(i) / hffac(i) + endif enddo endif From b542460cda828d83f4c6544b6a93c8523299fec8 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:03:52 +0000 Subject: [PATCH 069/165] updated GFS surface generic meta --- physics/GFS_surface_generic.meta | 50 ++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 21 deletions(-) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index e174de153..963fde747 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -1222,6 +1222,23 @@ kind = kind_phys intent = inout optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [runoff] standard_name = total_runoff long_name = total water runoff @@ -1266,18 +1283,18 @@ type = logical intent = in optional = F -[z0fac] - standard_name = surface_roughness_fraction_factor - long_name = surface roughness fraction factor for canopy heat storage parameterization +[h0facu] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_unstable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in unstable surface layer units = none dimensions = () type = real kind = kind_phys intent = in optional = F -[e0fac] - standard_name = latent_heat_flux_fraction_factor_relative_to_sensible_heat_flux - long_name = latent heat flux fraction factor relative to sensible heat flux for canopy heat storage parameterization +[h0facs] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_stable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in stable surface layer units = none dimensions = () type = real @@ -1312,18 +1329,18 @@ intent = in optional = F [hflxq] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out optional = F -[evapq] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness - units = kg kg-1 m s-1 +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -1338,15 +1355,6 @@ kind = kind_phys intent = out optional = F -[hefac] - standard_name = surface_upward_latent_heat_flux_reduction_factor - long_name = surface upward latent heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From b8a3a7ebdc6d9a39fe6837571a40b9891b3cc882 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:05:36 +0000 Subject: [PATCH 070/165] updated mfpblq --- physics/mfpbltq.f | 35 ++++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index a6fc22cef..b906052cd 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -40,12 +40,13 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, c local variables and arrays ! integer i, j, k, n, ndc + integer kpblx(im), kpbly(im) ! real(kind=kind_phys) dt2, dz, ce0, cm, & factor, gocp, & g, b1, f1, & bb1, bb2, - & a1, pgcon, + & alp, vpertmax,a1, pgcon, & qmin, qlmin, xmmx, rbint, & tem, tem1, tem2, & ptem, ptem1, ptem2 @@ -54,7 +55,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & tlu, gamma, qlu, & thup, thvu, dq ! - real(kind=kind_phys) rbdn(im), rbup(im), xlamuem(im,km-1) + real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), + & xlamuem(im,km-1) real(kind=kind_phys) delz(im), xlamax(im) ! real(kind=kind_phys) wu2(im,km), thlu(im,km), @@ -71,7 +73,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0) parameter(qmin=1.e-8,qlmin=1.e-12) - parameter(pgcon=0.55) + parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) parameter(b1=0.5,f1=0.15) ! !************************************************************************ @@ -99,9 +101,11 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do i=1,im if(cnvflg(i)) then - thlu(i,1)= thlx(i,1) + vpert(i) + ptem = alp * vpert(i) + ptem = min(ptem, vpertmax) + thlu(i,1)= thlx(i,1) + ptem qtu(i,1) = qtx(i,1) - buo(i,1) = g * vpert(i) / thvx(i,1) + buo(i,1) = g * ptem / thvx(i,1) endif enddo ! @@ -213,6 +217,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do i=1,im flg(i) = .true. + kpblx(i) = 1 + kpbly(i) = kpbl(i) if(cnvflg(i)) then flg(i) = .false. rbup(i) = wu2(i,1) @@ -223,14 +229,14 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, if(.not.flg(i)) then rbdn(i) = rbup(i) rbup(i) = wu2(i,k) - kpbl(i)= k + kpblx(i)= k flg(i) = rbup(i).le.0. endif enddo enddo do i = 1,im if(cnvflg(i)) then - k = kpbl(i) + k = kpblx(i) if(rbdn(i) <= 0.) then rbint = 0. elseif(rbup(i) >= 0.) then @@ -238,7 +244,17 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, else rbint = rbdn(i)/(rbdn(i)-rbup(i)) endif - hpbl(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + endif + enddo +! + do i = 1,im + if(cnvflg(i)) then + if(kpblx(i) < kpbl(i)) then + kpbl(i) = kpblx(i) + hpbl(i) = hpblx(i) + endif + if(kpbl(i) <= 1) cnvflg(i)=.false. endif enddo ! @@ -255,7 +271,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do k = 1, kmpbl do i=1,im - if(cnvflg(i)) then + if(cnvflg(i) .and. kpblx(i) < kpbly(i)) then +! if(cnvflg(i)) then if(k < kpbl(i)) then ptem = 1./(zm(i,k)+delz(i)) tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) From 4d301b16e6825393b3f0bd703248d43c67c0437a Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:11:33 +0000 Subject: [PATCH 071/165] updated evap & hflx --- physics/module_MYJPBL_wrapper.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta index 9d70397e7..a064cbd85 100644 --- a/physics/module_MYJPBL_wrapper.meta +++ b/physics/module_MYJPBL_wrapper.meta @@ -474,7 +474,7 @@ intent = inout optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) @@ -483,8 +483,8 @@ intent = in optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real From 3bdbf1cfcfc3c3d71ca12546a12fe0808d5d4c8c Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:15:27 +0000 Subject: [PATCH 072/165] updated hflx & qflx --- physics/module_MYNNPBL_wrapper.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index de24fcbef..6d87959f9 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -343,8 +343,8 @@ intent = out optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -352,8 +352,8 @@ intent = in optional = F [qflx] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real From a034b146aab50861ff07eb6e9f2ef71fa502a845 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:22:10 +0000 Subject: [PATCH 073/165] updated heat & evap --- physics/moninedmf.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 24096cbe6..9862efe9f 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -250,8 +250,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -259,7 +259,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From b567312333a6b0f32589ecce4075571622a96b20 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:25:51 +0000 Subject: [PATCH 074/165] updated heat & evap --- physics/moninshoc.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index 51f2c4536..18c047331 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -248,8 +248,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -257,7 +257,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From 26838633e1e516323a8ec1cf408534317da6e3bc Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:32:14 +0000 Subject: [PATCH 075/165] updated deep convection --- physics/samfdeepcnv.f | 389 +++++++++++++++++++++++++++--------------- 1 file changed, 250 insertions(+), 139 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 425aa92a9..a8905696c 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -10,9 +10,10 @@ module samfdeepcnv contains - subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & + subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, +& & errmsg, errflg) - + integer, intent(in) :: imfdeepcnv integer, intent(in) :: imfdeepcnv_samf character(len=*), intent(out) :: errmsg @@ -21,7 +22,8 @@ subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & ! Consistency checks if (imfdeepcnv/=imfdeepcnv_samf) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', & + write(errmsg,'(*(a))') 'Logic error: namelist choice of', +& & ' deep convection is different from SAMF scheme' errflg = 1 return @@ -80,10 +82,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & t0c,delt,ntk,ntr,delp, & & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav,hwrf_samfdeep, & & cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, & - & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & + & dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& - & clam,c0s,c1,betal,betas,evfact,evfactl,pgcon,asolfac, & + & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & & rainevap, & & errmsg,errflg) @@ -99,7 +101,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & fv, grav, hvap, rd, rv, t0c real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & - & prslp(:,:), garea(:), dot(:,:), phil(:,:) + & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: hwrf_samfdeep real(kind=kind_phys), intent(in) :: nthresh @@ -108,6 +110,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & logical, intent(in) :: do_ca,ca_closure,ca_entr,ca_trigger integer, intent(inout) :: kcnv(:) + ! DH* TODO - check dimensions of qtr, ntr+2 correct? *DH real(kind=kind_phys), intent(inout) :: qtr(:,:,:), & & q1(:,:), t1(:,:), u1(:,:), v1(:,:), & & cnvw(:,:), cnvc(:,:) @@ -128,7 +131,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: clam, c0s, c1, & & betal, betas, asolfac, & - & evfact, evfactl, pgcon + & evef, pgcon character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -137,12 +140,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! integer latd,lond ! real(kind=kind_phys) clamd, tkemx, tkemn, dtke, - & beta, dbeta, betamx, betamn, + & beta, clamca, & cxlame, cxlamd, - & cxlamu, & xlamde, xlamdd, - & crtlamd, - & crtlame + & crtlame, crtlamd ! ! real(kind=kind_phys) detad real(kind=kind_phys) adw, aup, aafac, d0, @@ -157,7 +158,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & edtmaxl, edtmaxs, el2orc, elocp, & es, etah, & cthk, dthk, - & evef, fact1, fact2, factor, +! & evfact, evfactl, + & fact1, fact2, factor, & gamma, pprime, cm, & qlk, qrch, qs, & rain, rfact, shear, tfac, @@ -171,15 +173,16 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & xqrch, tem, tem1, tem2, & ptem, ptem1, ptem2 ! - integer kb(im), kbcon(im), kbcon1(im), + integer kb(im), kb1(im), kbcon(im), kbcon1(im), & ktcon(im), ktcon1(im), ktconn(im), & jmin(im), lmin(im), kbmax(im), - & kbm(im), kmax(im) + & kbm(im), kmax(im), kd94(im) ! ! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), real(kind=kind_phys) aa1(im), tkemean(im),clamt(im), & ps(im), del(im,km), prsl(im,km), - & umean(im), tauadv(im), gdx(im), +! & umean(im), tauadv(im), gdx(im), + & gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), & deltv(im), dtconv(im), edt(im), @@ -197,10 +200,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! & xpwev(im), delebar(im,ntr), & delubar(im), delvbar(im) ! - real(kind=kind_phys) c0(im) + real(kind=kind_phys) c0(im), sfcpbl(im) cj real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, - & cinacr, cinacrmx, cinacrmn + & cinacr, cinacrmx, cinacrmn, + & sfclfac, rhcrt cj ! ! parameters for updraft velocity calculation @@ -226,9 +230,9 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & parameter(cm=1.0) ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) + parameter(clamca=0.03) parameter(dtke=tkemx-tkemn) - parameter(dbeta=0.1) - parameter(cthk=150.,dthk=25.) + parameter(cthk=200.,dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) ! parameter(cinacrmx=-120.,cinacrmn=-120.) parameter(cinacrmx=-120.,cinacrmn=-80.) @@ -251,7 +255,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), & dbyo(im,km), zo(im,km), & xlamue(im,km), xlamud(im,km), - & fent1(im,km), fent2(im,km), frh(im,km), + & fent1(im,km), fent2(im,km), + & rh(im,km), frh(im,km), & heo(im,km), heso(im,km), & qrcd(im,km), dellah(im,km), dellaq(im,km), & dellae(im,km,ntr), @@ -262,7 +267,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & qrcko(im,km), qrcdo(im,km), & pwo(im,km), pwdo(im,km), c0t(im,km), & tx1(im), sumx(im), cnvwt(im,km) -! &, rhbar(im) + &, rhbar(im) ! logical do_aerosols, totflg, cnvflg(im), asqecflg(im), flg(im) ! @@ -317,6 +322,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c do i=1,im cnvflg(i) = .true. + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. kbot(i)=km+1 @@ -424,16 +430,17 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! model tunable parameters are all here edtmaxl = .3 edtmaxs = .3 +! evfact = 0.3 +! evfactl = 0.3 + aafac = .1 if (hwrf_samfdeep) then - aafac = .1 - cxlamu = 1.0e-3 + cxlame = 1.0e-3 else - aafac = .05 cxlame = 1.0e-4 endif - crtlamd = 1.0e-4 + cxlamd = 0.75e-4 crtlame = 1.0e-4 - cxlamd = 1.0e-4 + crtlamd = 1.0e-4 xlamde = 1.0e-4 xlamdd = 1.0e-4 ! @@ -457,6 +464,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & kbmax(i) = km kbm(i) = km kmax(i) = km + kd94(i) = km tx1(i) = 1.0 / ps(i) enddo ! @@ -465,12 +473,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if (prsl(i,k)*tx1(i) > 0.04) kmax(i) = k + 1 if (prsl(i,k)*tx1(i) > 0.45) kbmax(i) = k + 1 if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.94) kd94(i) = k + 1 enddo enddo do i=1,im kmax(i) = min(km,kmax(i)) kbmax(i) = min(kbmax(i),kmax(i)) kbm(i) = min(kbm(i),kmax(i)) + kd94(i) = min(kd94(i),kmax(i)) enddo c c hydrostatic height assume zero terr and initially assume @@ -507,6 +517,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & eta(i,k) = 1. fent1(i,k)= 1. fent2(i,k)= 1. + rh(i,k) = 0. frh(i,k) = 0. hcko(i,k) = 0. qcko(i,k) = 0. @@ -591,14 +602,32 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c this is the level where updraft starts c !> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). -!> - Search below index "kbm" for the level of maximum moist static energy. +!> - Find the index for a level of sfclfac*hpbl which is initial guess for the parcel starting level. + do i=1,im + flg(i) = .true. + kb1(i) = 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo do i=1,im - hmax(i) = heo(i,1) - kb(i) = 1 + kb1(i) = min(kb1(i),kbm(i)) + enddo +c +!> - Search below index "kbm" and above kb1 for the level of maximum moist static energy. + do i=1,im + hmax(i) = heo(i,kb1(i)) + kb(i) = kb1(i) enddo do k = 2, km do i=1,im - if (k <= kbm(i)) then + if (k > kb1(i) .and. k <= kbm(i)) then if(heo(i,k) > hmax(i)) then kb(i) = k hmax(i) = heo(i,k) @@ -640,8 +669,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & val2 = 1.e-10 qo(i,k) = max(qo(i,k), val2 ) ! qo(i,k) = min(qo(i,k),qeso(i,k)) - tem = min(qo(i,k)/qeso(i,k), 1.) - frh(i,k) = 1. - tem + rh(i,k) = min(qo(i,k)/qeso(i,k), 1.) + frh(i,k) = 1. - rh(i,k) heo(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + & cp * to(i,k) + hvap * qo(i,k) heso(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + @@ -685,14 +714,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i=1,im if(kbcon(i) == kmax(i)) cnvflg(i) = .false. enddo -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif !! totflg = .true. do i=1,im @@ -746,13 +767,112 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & enddo !! if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo + endif + + totflg = .true. do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! re-define kb & kbcon +! + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kbm(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +! + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. k <= kbmax(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +! + do i=1,im + if(cnvflg(i) .and. kbcon(i) == kmax(i)) then + cnvflg(i) = .false. + endif + enddo +!! + if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif + + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +! +!> - if the mean relative humidity in the subcloud layers is less than a threshold value (rhcrt), convection is not triggered. +! + do i = 1, im + rhbar(i) = 0. + sumx(i) = 0. + enddo + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + rhbar(i) = rhbar(i) + rh(i,k) * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + rhbar(i) = rhbar(i) / sumx(i) + if(rhbar(i) < rhcrt) then + cnvflg(i) = .false. + endif + endif + enddo !! + if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo + endif + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -760,6 +880,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(totflg) return !! ! +!Lisa: at this point only trigger criteria is set + ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE ! @@ -799,13 +921,25 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! + if(do_ca .and. ca_entr)then + do i=1,im + if(cnvflg(i)) then + if(ca_deep(i) > nthresh)then + clamt(i) = clam - clamca + else + clamt(i) = clam + endif + endif + enddo + endif + else ! if(do_ca .and. ca_entr)then do i=1,im if(cnvflg(i)) then if(ca_deep(i) > nthresh)then - clamt(i) = clam - clamd + clamt(i) = clam - clamca else clamt(i) = clam endif @@ -827,7 +961,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i)) then - xlamue(i,k) = clamt(i) / zi(i,k) + dz =zo(i,k+1) - zo(i,k) + xlamue(i,k) = clamt(i) / (zi(i,k) + dz) xlamue(i,k) = max(xlamue(i,k), crtlame) endif enddo @@ -874,6 +1009,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i) .and. k < kmax(i)) then +! xlamud(i,k) = crtlamd xlamud(i,k) = 0.001 * clamt(i) endif enddo @@ -904,7 +1040,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i=1,im if(cnvflg(i) .and. & (k > kbcon(i) .and. k < kmax(i))) then - tem = cxlamu * frh(i,k) * fent2(i,k) + tem = cxlame * frh(i,k) * fent2(i,k) xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem endif enddo @@ -1071,14 +1207,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo !! + if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. do i = 1, im totflg = totflg .and. (.not. cnvflg(i)) @@ -1154,13 +1290,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif !hwrf_samfdeep !! if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -1195,21 +1330,22 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(tem < cthk) cnvflg(i) = .false. endif enddo -!! + + if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. - do i = 1, im + do i=1,im totflg = totflg .and. (.not. cnvflg(i)) enddo if(totflg) return !! + c c search for downdraft originating level above theta-e minimum c @@ -1644,60 +1780,34 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i = 1, im if(cnvflg(i)) then - if(k >= 1 .and. k < kbcon(i)) then + if(k >= 1 .and. k < kd94(i)) then dz = zi(i,k+1) - zi(i,k) sumx(i) = sumx(i) + dz endif endif enddo enddo - - if (hwrf_samfdeep) then - do i = 1, im + do i = 1, im beta = betas if(islimsk(i) == 1) beta = betal if(cnvflg(i)) then - dz = (sumx(i)+zi(i,1))/float(kbcon(i)) - tem = 1./float(kbcon(i)) + dz = (sumx(i)+zi(i,1))/float(kd94(i)) + tem = 1./float(kd94(i)) xlamd(i) = (1.-beta**tem)/dz endif - enddo - else - do i = 1, im - if(cnvflg(i)) then - betamn = betas - if(islimsk(i) == 1) betamn = betal - if(ntk > 0) then - betamx = betamn + dbeta - if(tkemean(i) > tkemx) then - beta = betamn - else if(tkemean(i) < tkemn) then - beta = betamx - else - tem = (betamx - betamn) * (tkemean(i) - tkemn) - beta = betamx - tem / dtke - endif - else - beta = betamn - endif - dz = (sumx(i)+zi(i,1))/float(kbcon(i)) - tem = 1./float(kbcon(i)) - xlamd(i) = (1.-beta**tem)/dz - endif - enddo - endif + enddo c c determine downdraft mass flux c -!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the LFC. +!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the level of 60mb above the ground surface (kd94). do k = km1, 1, -1 do i = 1, im if (cnvflg(i) .and. k <= kmax(i)-1) then - if(k < jmin(i) .and. k >= kbcon(i)) then + if(k < jmin(i) .and. k >= kd94(i)) then dz = zi(i,k+1) - zi(i,k) ptem = xlamdd - xlamde etad(i,k) = etad(i,k+1) * (1. - ptem * dz) - else if(k < kbcon(i)) then + else if(k < kd94(i)) then dz = zi(i,k+1) - zi(i,k) ptem = xlamd(i) + xlamdd - xlamde etad(i,k) = etad(i,k+1) * (1. - ptem * dz) @@ -1737,7 +1847,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -1786,7 +1896,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -1935,7 +2045,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) c - if(k <= kbcon(i)) then + if(k <= kd94(i)) then ptem = xlamde ptem1 = xlamd(i)+xlamdd else @@ -2247,7 +2357,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if (asqecflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -2272,7 +2382,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -2424,40 +2534,41 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. - do i= 1, im - if(cnvflg(i)) then - sumx(i) = 0. - umean(i) = 0. - endif - enddo - do k = 2, km1 - do i = 1, im - if(cnvflg(i)) then - if(k >= kbcon1(i) .and. k < ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) - umean(i) = umean(i) + tem * dz - sumx(i) = sumx(i) + dz - endif - endif - enddo - enddo - do i= 1, im - if(cnvflg(i)) then - umean(i) = umean(i) / sumx(i) - umean(i) = max(umean(i), 1.) - tauadv(i) = gdx(i) / umean(i) - endif - enddo +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! umean(i) = 0. +! endif +! enddo +! do k = 2, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kbcon1(i) .and. k < ktcon1(i)) then +! dz = zi(i,k) - zi(i,k-1) +! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) +! umean(i) = umean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! do i= 1, im +! if(cnvflg(i)) then +! umean(i) = umean(i) / sumx(i) +! umean(i) = max(umean(i), 1.) +! tauadv(i) = gdx(i) / umean(i) +! endif +! enddo !> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = tfac*betaw*rho*wc(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = tfac*betaw*rho*wc(i) + xmb(i) = betaw*rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2497,9 +2608,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! !! Again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. if(asqecflg(i)) then - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = -tfac * fld(i) / xk(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = -tfac * fld(i) / xk(i) + xmb(i) = -fld(i) / xk(i) endif enddo !! @@ -2713,10 +2825,9 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 endif if(flg(i) .and. k < ktcon(i)) then - evef = edt(i) * evfact - if(islimsk(i) == 1) evef=edt(i) * evfactl +! evef = edt(i) * evfact +! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 -c if(islimsk(i) == 1) evef = 0. qcond(i) = evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) From f44d15a20f5d9b543ce08be58eb2e9c96262bef9 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:35:26 +0000 Subject: [PATCH 076/165] updated samfdeepcnv.meta --- physics/samfdeepcnv.meta | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index ff3c0d115..8a2a16fe7 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -375,6 +375,15 @@ type = integer intent = in optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL top height + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [ud_mf] standard_name = instantaneous_atmosphere_updraft_convective_mass_flux long_name = (updraft mass flux) * delt @@ -571,18 +580,9 @@ kind = kind_phys intent = in optional = F -[evfact] - standard_name = rain_evaporation_coefficient_deep_convection - long_name = convective rain evaporation coefficient for deep conv. - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[evfactl] - standard_name = rain_evaporation_coefficient_over_land_deep_convection - long_name = convective rain evaporation coefficient over land for deep conv. +[evef] + standard_name = rain_evaporation_coefficient_convection + long_name = convective rain evaporation coefficient for convection units = frac dimensions = () type = real From 64b3d2d183f742a1a5ecb5a45bedb85e4d074722 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:44:21 +0000 Subject: [PATCH 077/165] updated shallow convection --- physics/samfshalcnv.f | 315 ++++++++++++++++++++++++++++-------------- 1 file changed, 209 insertions(+), 106 deletions(-) diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 1697cfe35..cfc7654f8 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -9,23 +9,25 @@ module samfshalcnv contains - subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, & + subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, +& & errmsg, errflg) integer, intent(in) :: imfshalcnv integer, intent(in) :: imfshalcnv_samf - + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Consistency checks if (imfshalcnv/=imfshalcnv_samf) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', & + write(errmsg,'(*(a))') 'Logic error: namelist choice of', +& & ' shallow convection is different from SAMF' errflg = 1 return - end if + end if end subroutine samfshalcnv_init subroutine samfshalcnv_finalize() @@ -61,7 +63,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & - & clam,c0s,c1,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) + & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -87,7 +89,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:) ! real(kind=kind_phys), intent(in) :: clam, c0s, c1, & - & asolfac, pgcon + & asolfac, evef, pgcon logical, intent(in) :: hwrf_samfshal character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -108,8 +110,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & dz, dz1, e1, & el2orc, elocp, aafac, cm, & es, etah, h1, - & evef, evfact, evfactl, fact1, - & fact2, factor, dthk, +! & evfact, evfactl, + & fact1, fact2, factor, dthk, & gamma, pprime, betaw, & qlk, qrch, qs, & rfact, shear, tfac, @@ -120,30 +122,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & rho, tem, tem1, tem2, & ptem, ptem1 ! - integer kb(im), kbcon(im), kbcon1(im), + integer kb(im), kb1(im), kbcon(im), kbcon1(im), & ktcon(im), ktcon1(im), ktconn(im), & kbm(im), kmax(im) ! real(kind=kind_phys) aa1(im), cina(im), & tkemean(im), clamt(im), & ps(im), del(im,km), prsl(im,km), - & umean(im), tauadv(im), gdx(im), +! & umean(im), tauadv(im), gdx(im), + & gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), - & deltv(im), dtconv(im), edt(im), +! & deltv(im), dtconv(im), edt(im), + & deltv(im), dtconv(im), & pdot(im), po(im,km), & qcond(im), qevap(im), hmax(im), - & rntot(im), vshear(im), +! & rntot(im), vshear(im), + & rntot(im), & xlamud(im), xmb(im), xmbmax(im), & delebar(im,ntr), & delubar(im), delvbar(im) ! - real(kind=kind_phys) c0(im) + real(kind=kind_phys) c0(im), sfcpbl(im) c - real(kind=kind_phys) crtlamd + real(kind=kind_phys) crtlame, crtlamd ! real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, - & cinacr, cinacrmx, cinacrmn + & cinacr, cinacrmx, cinacrmn, + & sfclfac, rhcrt ! ! parameters for updraft velocity calculation real(kind=kind_phys) bet1, cd1, f1, gam1, @@ -172,10 +178,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) parameter(clamd=0.1,tkemx=0.65,tkemn=0.05) parameter(dtke=tkemx-tkemn) - parameter(dthk=25.) + parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) parameter(cinacrmx=-120.) - parameter(crtlamd=3.e-4) parameter(dtmax=10800.,dtmin=600.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrt=15.e3) @@ -194,6 +199,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), & dbyo(im,km), zo(im,km), xlamue(im,km), + & rh(im,km), & heo(im,km), heso(im,km), & dellah(im,km), dellaq(im,km), & dellae(im,km,ntr), @@ -203,6 +209,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eta(im,km), & zi(im,km), pwo(im,km), c0t(im,km), & sumx(im), tx1(im), cnvwt(im,km) + &, rhbar(im) ! logical do_aerosols, totflg, cnvflg(im), flg(im) ! @@ -255,6 +262,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kbot(i)=km+1 ktop(i)=0 endif + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. kbcon(i)=km ktcon(i)=1 @@ -262,10 +270,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. - edt(i) = 0. +! edt(i) = 0. aa1(i) = 0. cina(i) = 0. - vshear(i) = 0. +! vshear(i) = 0. gdx(i) = sqrt(garea(i)) scaldfunc(i)=-1.0 ! wang initialized sigmagfm(i)=-1.0 @@ -279,6 +287,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kbot(i)=km+1 ktop(i)=0 endif + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. kbcon(i)=km ktcon(i)=1 @@ -286,10 +295,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. - edt(i) = 0. +! edt(i) = 0.0 aa1(i) = 0. cina(i) = 0. - vshear(i) = 0. +! vshear(i) = 0. gdx(i) = sqrt(garea(i)) enddo endif @@ -342,14 +351,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & dt2 = delt ! c model tunable parameters are all here - if (hwrf_samfshal) then - aafac = .1 - else - aafac = .05 - endif -c evef = 0.07 - evfact = 0.3 - evfactl = 0.3 + aafac = .1 +! evfact = 0.3 +! evfactl = 0.3 +! + crtlame = 1.0e-4 + crtlamd = 3.0e-4 ! w1l = -8.e-3 w2l = -4.e-2 @@ -437,6 +444,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if (cnvflg(i) .and. k <= kmax(i)) then pfld(i,k) = prsl(i,k) * 10.0 eta(i,k) = 1. + rh(i,k) = 0. hcko(i,k) = 0. qcko(i,k) = 0. qrcko(i,k)= 0. @@ -510,16 +518,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c this is the level where updraft starts c !> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!> - Find the index for a level of sfclfac*hpbl which is initial guess for the parcel starting level. + do i=1,im + flg(i) = cnvflg(i) + kb1(i) = 1 + enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kb1(i) = min(kb1(i),kpbl(i)) + enddo +c !> - Search in the PBL for the level of maximum moist static energy to start the ascending parcel. do i=1,im if (cnvflg(i)) then - hmax(i) = heo(i,1) - kb(i) = 1 + hmax(i) = heo(i,kb1(i)) + kb(i) = kb1(i) endif enddo do k = 2, km do i=1,im - if (cnvflg(i) .and. k <= kpbl(i)) then + if(cnvflg(i) .and. (k > kb1(i) .and. k <= kpbl(i))) then if(heo(i,k) > hmax(i)) then kb(i) = k hmax(i) = heo(i,k) @@ -561,6 +587,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & val2 = 1.e-10 qo(i,k) = max(qo(i,k), val2 ) ! qo(i,k) = min(qo(i,k),qeso(i,k)) + rh(i,k) = min(qo(i,k)/qeso(i,k), 1.) heo(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + & cp * to(i,k) + hvap * qo(i,k) heso(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + @@ -666,11 +693,95 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo if(totflg) return ! +! re-define kb & kbcon +! + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kpbl(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +! + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +! + do i=1,im + if(cnvflg(i)) then + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +! +!> - if the mean relative humidity in the subcloud layers is less than a threshold value (rhcrt), convection is not triggered. +! + do i = 1, im + rhbar(i) = 0. + sumx(i) = 0. + enddo + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + rhbar(i) = rhbar(i) + rh(i,k) * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + rhbar(i) = rhbar(i) / sumx(i) + if(rhbar(i) < rhcrt) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE ! -! - !c !c specify the detrainment rate for the updrafts !c @@ -735,7 +846,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i)) then - xlamue(i,k) = clamt(i) / zi(i,k) + dz = zo(i,k+1) - zo(i,k) + xlamue(i,k) = clamt(i) / (zi(i,k) + dz) + xlamue(i,k) = max(xlamue(i,k), crtlame) endif enddo enddo @@ -1006,23 +1119,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c specify upper limit of mass flux at cloud base c !> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. - if(hwrf_samfshal) then - do i = 1, im + do i = 1, im if(cnvflg(i)) then k = kbcon(i) dp = 1000. * del(i,k) xmbmax(i) = dp / (grav * dt2) endif - enddo - else - do i = 1, im - if(cnvflg(i)) then - k = kbcon(i) - dp = 1000. * del(i,k) - xmbmax(i) = dp / (2. * grav * dt2) - endif - enddo - endif + enddo c c compute cloud moisture property and precipitation c @@ -1349,34 +1452,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & !! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 !! \f] !! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edt" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 0. - endif - enddo - do k = 2, km - do i = 1, im - if (cnvflg(i)) then - if(k > kb(i) .and. k <= ktcon(i)) then - shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 - & + (vo(i,k)-vo(i,k-1)) ** 2) - vshear(i) = vshear(i) + shear - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) - e1=1.591-.639*vshear(i) - & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) - edt(i)=1.-e1 - val = .9 - edt(i) = min(edt(i),val) - val = .0 - edt(i) = max(edt(i),val) - endif - enddo +! do i = 1, im +! if(cnvflg(i)) then +! vshear(i) = 0. +! endif +! enddo +! do k = 2, km +! do i = 1, im +! if (cnvflg(i)) then +! if(k > kb(i) .and. k <= ktcon(i)) then +! shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 +! & + (vo(i,k)-vo(i,k-1)) ** 2) +! vshear(i) = vshear(i) + shear +! endif +! endif +! enddo +! enddo +! do i = 1, im +! if(cnvflg(i)) then +! vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) +! e1=1.591-.639*vshear(i) +! & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) +! edt(i)=1.-e1 +! val = .9 +! edt(i) = min(edt(i),val) +! val = .0 +! edt(i) = max(edt(i),val) +! endif +! enddo c c--- what would the change be, that a cloud with unit mass c--- will do to the environment? @@ -1521,31 +1624,31 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. - do i= 1, im - if(cnvflg(i)) then - sumx(i) = 0. - umean(i) = 0. - endif - enddo - do k = 2, km1 - do i = 1, im - if(cnvflg(i)) then - if(k >= kbcon1(i) .and. k < ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) - umean(i) = umean(i) + tem * dz - sumx(i) = sumx(i) + dz - endif - endif - enddo - enddo - do i= 1, im - if(cnvflg(i)) then - umean(i) = umean(i) / sumx(i) - umean(i) = max(umean(i), 1.) - tauadv(i) = gdx(i) / umean(i) - endif - enddo +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! umean(i) = 0. +! endif +! enddo +! do k = 2, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kbcon1(i) .and. k < ktcon1(i)) then +! dz = zi(i,k) - zi(i,k-1) +! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) +! umean(i) = umean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! do i= 1, im +! if(cnvflg(i)) then +! umean(i) = umean(i) / sumx(i) +! umean(i) = max(umean(i), 1.) +! tauadv(i) = gdx(i) / umean(i) +! endif +! enddo c c compute cloud base mass flux as a function of the mean c updraft velcoity @@ -1556,9 +1659,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = tfac*betaw*rho*wc(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = tfac*betaw*rho*wc(i) + xmb(i) = betaw*rho*wc(i) endif enddo ! @@ -1722,10 +1826,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif if(flg(i) .and. k < ktcon(i)) then - evef = edt(i) * evfact - if(islimsk(i) == 1) evef=edt(i) * evfactl +! evef = edt(i) * evfact +! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 -c if(islimsk(i) == 1) evef = 0. qcond(i) = evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) From b5fca2756388f8e2b4b73e93a5ad6e47ca50c87c Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:48:18 +0000 Subject: [PATCH 078/165] updated samfshalcnv.meta --- physics/samfshalcnv.meta | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index a454da3e7..686f3ae7c 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -430,6 +430,15 @@ kind = kind_phys intent = in optional = F +[evef] + standard_name = rain_evaporation_coefficient_convection + long_name = convective rain evaporation coefficient for convection + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [pgcon] standard_name = momentum_transport_reduction_factor_pgf_shallow_convection long_name = reduction factor in momentum transport due to shal conv. induced pressure gradient force From 3e155b4264fd76df2bccc9bc7a1fe4854b211468 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:52:59 +0000 Subject: [PATCH 079/165] updated heat & evap --- physics/satmedmfvdif.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index baea94ad5..14b717f88 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -365,8 +365,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -374,7 +374,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From ed61f02c012a993c6dc77dc857ff6bd4181b2c6f Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 17:57:49 +0000 Subject: [PATCH 080/165] updated TKE-EDMF --- physics/satmedmfvdifq.F | 252 ++++++++++++++++++++++++---------------- 1 file changed, 154 insertions(+), 98 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 4bbfe61cc..c1ad33b08 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -35,7 +35,7 @@ subroutine satmedmfvdifq_init (satmedmf, ! Consistency checks if (.not. satmedmf) then - write(errmsg,fmt='(*(a))') 'Logic error: satmedmf = .false.' + write(errmsg,fmt='(*(a))') 'Logic error: satmedmf = .false.' errflg = 1 return end if @@ -69,8 +69,8 @@ end subroutine satmedmfvdifq_finalize !! @{ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,islimsk, & - & snwdph_lnd,psk,rbsoil,zorl,u10m,v10m,fm,fh, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,zvfun, & + & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & @@ -86,7 +86,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !---------------------------------------------------------------------- integer, intent(in) :: im, km, ntrac, ntcw, ntiw, ntke, ntoz integer, intent(in) :: kinver(:) - integer, intent(in) :: islimsk(:) integer, intent(out) :: kpbl(:) logical, intent(in) :: gen_tend,ldiag3d,qdiag3d ! @@ -101,7 +100,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & - & snwdph_lnd(:), & + & zvfun(:), & & psk(:), rbsoil(:), & & zorl(:), tsea(:), & & u10m(:), v10m(:), & @@ -116,8 +115,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & dt3dt(:,:), dq3dt(:,:), & & do3dt(:,:) real(kind=kind_phys), intent(out) :: & - & dusfc(:), dvsfc(:), & - & dtsfc(:), dqsfc(:), & + & dusfc(:), dvsfc(:), & + & dtsfc(:), dqsfc(:), & & hpbl(:) real(kind=kind_phys), intent(out) :: & & dkt(:,:), dku(:,:) @@ -151,7 +150,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & phih(im), phim(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), - & ust3(im), wst3(im), + & ust3(im), wst3(im), rho_a(im), & z0(im), crb(im), & hgamt(im), hgamq(im), & wscale(im),vpert(im), @@ -168,7 +167,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & f1(im,km), f2(im,km*(ntrac-1)) ! real(kind=kind_phys) elm(im,km), ele(im,km), - & ckz(im,km), chz(im,km), frik(im), + & ckz(im,km), chz(im,km), & diss(im,km-1),prod(im,km-1), & bf(im,km-1), shr2(im,km-1), & xlamue(im,km-1), xlamde(im,km-1), @@ -212,41 +211,41 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & epsi, beta, chx, cqx, & rdt, rdz, qmin, qlmin, & rimin, rbcr, rbint, tdzmin, - & rlmn, rlmn1, rlmn2, + & rlmn, rlmn0, rlmn1, rlmn2, & rlmx, elmx, & ttend, utend, vtend, qtend, & zfac, zfmin, vk, spdk2, - & tkmin, tkminx, xkzinv, xkgdx, - & zlup, zldn, bsum, - & tem, tem1, tem2, + & tkmin, tkbmx, xkgdx, + & xkinv1, xkinv2, + & zlup, zldn, bsum, cs0, + & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 -! - real(kind=kind_phys) xkzm_mp, xkzm_hp ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! - real(kind=kind_phys) qlcr, zstblmax + real(kind=kind_phys) qlcr, zstblmax, hcrinv ! real(kind=kind_phys) h1 !! - parameter(wfac=7.0,cfac=3.0) + parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) parameter(vk=0.4,rimin=-100.) parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) - parameter(rlmn=30.,rlmn1=5.,rlmn2=10.) + parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) parameter(rlmx=300.,elmx=300.) parameter(prmin=0.25,prmax=4.0) parameter(pr0=1.0,prtke=1.0,prscu=0.67) parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) - parameter(tkmin=1.e-9,tkminx=0.2,dspmax=10.0) + parameter(tkmin=1.e-9,tkbmx=0.2,dspmax=10.0) parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) parameter(aphi5=5.,aphi16=16.) parameter(elmfac=1.0,elefac=1.0,cql=100.) - parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=5000.) - parameter(qlcr=3.5e-5,zstblmax=2500.,xkzinv=0.1) - parameter(h1=0.33333333) + parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) + parameter(xkinv1=0.15,xkinv2=0.3) + parameter(h1=0.33333333,hcrinv=250.) parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) - parameter(ce0=0.4) + parameter(ce0=0.4,cs0=0.2) parameter(rchck=1.5,ndt=20) gravi=1.0/grav @@ -287,12 +286,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & buod(i,k) = 0. ckz(i,k) = ck1 chz(i,k) = ch1 - rlmnz(i,k) = rlmn + rlmnz(i,k) = rlmn0 enddo enddo - do i=1,im - frik(i) = 1.0 - enddo do i=1,im zi(i,km+1) = phii(i,km+1) * gravi enddo @@ -331,41 +327,22 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) -!> - set background diffusivities as a function of -!! horizontal grid size with xkzm_h & xkzm_m for gdx >= 25km -!! and 0.01 for gdx=5m, i.e., -!! \n xkzm_hx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) -!! \n xkzm_mx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) - - do i=1,im - xkzm_mp = xkzm_m - xkzm_hp = xkzm_h -! - if( islimsk(i) == 1 .and. snwdph_lnd(i) > 10.0 ) then ! over land - if (rbsoil(i) > 0. .and. rbsoil(i) <= 0.25) then - xkzm_mp = xkzm_m * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - xkzm_hp = xkzm_h * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - else if (rbsoil(i) > 0.25) then - xkzm_mp = 0.1 - xkzm_hp = 0.1 - endif - endif +!> - set background diffusivities with xkzm_h & xkzm_m for gdx >= xkgdx and +!! as a function of horizontal grid size for gdx < xkgdx +!! \n xkzm_hx = xkzm_h * (gdx / xkgdx) +!! \n xkzm_mx = xkzm_m * (gdx / xkgdx) ! + do i=1,im kx1(i) = 1 tx1(i) = 1.0 / prsi(i,1) tx2(i) = tx1(i) if(gdx(i) >= xkgdx) then - xkzm_hx(i) = xkzm_hp - xkzm_mx(i) = xkzm_mp + xkzm_hx(i) = xkzm_h + xkzm_mx(i) = xkzm_m else - tem = 1. / (xkgdx - 5.) - tem1 = (xkzm_hp - 0.01) * tem - tem2 = (xkzm_mp - 0.01) * tem - ptem = gdx(i) - 5. - xkzm_hx(i) = 0.01 + tem1 * ptem - xkzm_mx(i) = 0.01 + tem2 * ptem + tem = gdx(i) / xkgdx + xkzm_hx(i) = xkzm_h * tem + xkzm_mx(i) = xkzm_m * tem endif enddo do k = 1,km1 @@ -374,19 +351,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & xkzmo(i,k) = 0.0 if (k < kinver(i)) then ! minimum turbulent mixing length - ptem = prsl(i,k) * tx1(i) + ptem = prsi(i,k+1) * tx1(i) tem1 = 1.0 - ptem tem2 = tem1 * tem1 * 2.5 tem2 = min(1.0, exp(-tem2)) rlmnz(i,k)= rlmn * tem2 - rlmnz(i,k)= max(rlmnz(i,k), rlmn1) + rlmnz(i,k)= max(rlmnz(i,k), rlmn0) ! vertical background diffusivity - ptem = prsi(i,k+1) * tx1(i) - tem1 = 1.0 - ptem tem2 = tem1 * tem1 * 10.0 tem2 = min(1.0, exp(-tem2)) xkzo(i,k) = xkzm_hx(i) * tem2 -! vertical background diffusivity for momentum +! vertical background diffusivity for +! momentum if (ptem >= xkzm_s) then xkzmo(i,k) = xkzm_mx(i) kx1(i) = k + 1 @@ -399,10 +375,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & endif enddo enddo - +! !> - Some output variables and logical flags are initialized do i = 1,im z0(i) = 0.01 * zorl(i) + rho_a(i) = prsl(i,1) / (rd * t1(i,1)) dusfc(i) = 0. dvsfc(i) = 0. dtsfc(i) = 0. @@ -710,10 +687,54 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & hgamq(i) = evap(i)/wscale(i) vpert(i) = hgamt(i) + hgamq(i)*fv*theta(i,1) vpert(i) = max(vpert(i),0.) - vpert(i) = min(cfac*vpert(i),gamcrt) + tem = min(cfac*vpert(i),gamcrt) + thermal(i)= thermal(i) + tem endif enddo ! +! enhance the pbl height by considering the thermal excess +! (overshoot pbl top) +! + do i=1,im + flg(i) = .true. + if(pcnvflg(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)**2+v1(i,k)**2),1.) + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pcnvflg(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 + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) then + kpbl(i) = kpbl(i) - 1 + endif + if(kpbl(i) <= 1) then + pcnvflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! look for stratocumulus !> ## Determine whether stratocumulus layers exist and compute quantities @@ -848,38 +869,43 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & enddo enddo ! -! background diffusivity decreasing with increasing surface layer stability -! -! do i = 1, im -! if(.not.sfcflg(i)) then -! tem = (1. + 5. * rbsoil(i))**2. -!! tem = (1. + 5. * zol(i))**2. -! frik(i) = 0.1 + 0.9 / tem -! endif -! enddo +! Above a threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are set to much smaller values (xkinv1 & +! rlmn1) ! -! do k = 1,km1 -! do i=1,im -! xkzo(i,k) = frik(i) * xkzo(i,k) -! xkzmo(i,k)= frik(i) * xkzmo(i,k) -! enddo -! enddo -! -!> ## The background vertical diffusivities in the inversion layers are limited -!! to be less than or equal to xkzinv +! Below the threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are increased with increasing roughness +! length & vegetation fraction ! do k = 1,km1 do i=1,im -! tem1 = (tvx(i,k+1)-tvx(i,k)) * rdzt(i,k) -! if(tem1 > 1.e-5) then - tem1 = tvx(i,k+1)-tvx(i,k) - if(tem1 > 0. .and. islimsk(i) /= 1) then - xkzo(i,k) = min(xkzo(i,k), xkzinv) - xkzmo(i,k) = min(xkzmo(i,k), xkzinv) - rlmnz(i,k) = min(rlmnz(i,k), rlmn2) + if(zi(i,k+1) > hcrinv) then + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 >= 0.) then + xkzo(i,k) = min(xkzo(i,k), xkinv1) + xkzmo(i,k) = min(xkzmo(i,k), xkinv1) + rlmnz(i,k) = min(rlmnz(i,k), rlmn1) + endif + else + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 > 0.) then + ptem = xkzo(i,k) * zvfun(i) + xkzo(i,k) = min(max(ptem, xkinv2), xkzo(i,k)) + ptem = xkzmo(i,k) * zvfun(i) + xkzmo(i,k) = min(max(ptem, xkinv2), xkzmo(i,k)) + ptem = rlmnz(i,k) * zvfun(i) + rlmnz(i,k) = min(max(ptem, rlmn2), rlmnz(i,k)) + endif endif enddo enddo + do k = 2,km1 + do i=1,im + rlmnz(i,k) = 0.5 * (rlmnz(i,k-1) + rlmnz(i,k)) + enddo + enddo ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> ## Compute an asymtotic mixing length @@ -892,8 +918,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & do n = k, km1 if(mlenflg) then dz = zl(i,n+1) - zl(i,n) - ptem = gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))*dz -! ptem = gotvx(i,n)*(thlvx(i,n+1)-thlvx(i,k))*dz +! tem1 = 0.5 * (thvx(i,n) + thvx(i,n+1)) +!! tem1 = 0.5 * (thlvx(i,n) + thlvx(i,n+1)) + tem3=((u1(i,n+1)-u1(i,n))/dz)**2 + tem3=tem3+((v1(i,n+1)-v1(i,n))/dz)**2 + tem3=cs0*sqrt(tem3)*sqrt(tke(i,k)) + ptem = (gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))+tem3)*dz +! ptem = (gotvx(i,n)*(thlvx(i,n+1)-thlvx(i,k)+tem3)*dz +! ptem = (gotvx(i,n)*(tem1-thvx(i,k))+tem3)*dz +!! ptem = (gotvx(i,n)*(tem1-thlvx(i,k)+tem3)*dz bsum = bsum + ptem zlup = zlup + dz if(bsum >= tke(i,k)) then @@ -917,13 +950,23 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & if(n == 1) then dz = zl(i,1) tem1 = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) +! tem1 = 0.5 * (tem1 + thvx(i,n)) +!! tem1 = 0.5 * (tem1 + thlvx(i,n)) + tem3 = (u1(i,1)/dz)**2 + tem3 = tem3+(v1(i,1)/dz)**2 + tem3 = cs0*sqrt(tem3)*sqrt(tke(i,1)) else dz = zl(i,n) - zl(i,n-1) tem1 = thvx(i,n-1) ! tem1 = thlvx(i,n-1) +! tem1 = 0.5 * (thvx(i,n-1) + thvx(i,n)) +!! tem1 = 0.5 * (thlvx(i,n-1) + thlvx(i,n)) + tem3 = ((u1(i,n)-u1(i,n-1))/dz)**2 + tem3 = tem3+((v1(i,n)-v1(i,n-1))/dz)**2 + tem3 = cs0*sqrt(tem3)*sqrt(tke(i,k)) endif - ptem = gotvx(i,n)*(thvx(i,k)-tem1)*dz -! ptem = gotvx(i,n)*(thlvx(i,k)-tem1)*dz + ptem = (gotvx(i,n)*(thvx(i,k)-tem1)+tem3)*dz +! ptem = (gotvx(i,n)*(thlvx(i,k)-tem1)+tem3)*dz bsum = bsum + ptem zldn = zldn + dz if(bsum >= tke(i,k)) then @@ -954,6 +997,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !! where \f$l_{up}\f$ and \f$l_{down}\f$ are the distances that a parcel !! having an initial TKE can travel upward and downward before being stopped !! by buoyancy effects. +! +! Following Rodier et. al (2017), environmental wind shear effect on +! mixing length was included. +! ptem2 = min(zlup,zldn) rlam(i,k) = elmfac * ptem2 rlam(i,k) = max(rlam(i,k), tem1) @@ -1063,7 +1110,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & endif ptem = tem1 / (tem * elm(i,k)) tkmnz(i,k) = ptem * ptem - tkmnz(i,k) = min(tkmnz(i,k), tkminx) + tkmnz(i,k) = min(tkmnz(i,k), tkbmx) tkmnz(i,k) = max(tkmnz(i,k), tkmin) enddo enddo @@ -1432,10 +1479,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend 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 +! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend +! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo + do i = 1,im + dtsfc(i) = rho_a(i) * cp * heat(i) + dqsfc(i) = rho_a(i) * hvap * evap(i) + enddo +! if(ldiag3d .and. .not. gen_tend) then do k = 1,km do i = 1,im @@ -1553,7 +1605,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & ! enddo enddo - c !> - Call tridi2() to solve tridiagonal problem for momentum c @@ -1567,10 +1618,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(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 +! dusfc(i) = dusfc(i)+conw*del(i,k)*utend +! dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo + do i = 1,im + dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + enddo +! if(ldiag3d .and. .not. gen_tend) then do k = 1,km do i = 1,im From fd2031051aebd898648c947e825e0d2b354e9b75 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:03:01 +0000 Subject: [PATCH 081/165] updated satmedmfvdifq.meta --- physics/satmedmfvdifq.meta | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index fd2dbe887..45a6fa5a1 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -290,18 +290,10 @@ kind = kind_phys intent = in optional = F -[islimsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[snwdph_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -380,8 +372,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -389,7 +381,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From c4f53940cd8b164ab023e08937be44ca43b58914 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:05:57 +0000 Subject: [PATCH 082/165] updated TKE-EDMF --- physics/satmedmfvdifq.F | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index c1ad33b08..a891fa387 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -150,7 +150,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & phih(im), phim(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), - & ust3(im), wst3(im), rho_a(im), +! & ust3(im), wst3(im), rho_a(im), + & ust3(im), wst3(im), & z0(im), crb(im), & hgamt(im), hgamq(im), & wscale(im),vpert(im), @@ -379,7 +380,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !> - Some output variables and logical flags are initialized do i = 1,im z0(i) = 0.01 * zorl(i) - rho_a(i) = prsl(i,1) / (rd * t1(i,1)) +! rho_a(i) = prsl(i,1) / (rd * t1(i,1)) dusfc(i) = 0. dvsfc(i) = 0. dtsfc(i) = 0. @@ -1479,14 +1480,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend 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 + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo - do i = 1,im - dtsfc(i) = rho_a(i) * cp * heat(i) - dqsfc(i) = rho_a(i) * hvap * evap(i) - enddo +! do i = 1,im +! dtsfc(i) = rho_a(i) * cp * heat(i) +! dqsfc(i) = rho_a(i) * hvap * evap(i) +! enddo ! if(ldiag3d .and. .not. gen_tend) then do k = 1,km @@ -1618,14 +1619,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(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 + dusfc(i) = dusfc(i)+conw*del(i,k)*utend + dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo - do i = 1,im - dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) - dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) - enddo +! do i = 1,im +! dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) +! dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) +! enddo ! if(ldiag3d .and. .not. gen_tend) then do k = 1,km From 3175790051d3042b867b58e30d0155012a5d36bb Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:09:14 +0000 Subject: [PATCH 083/165] updated TKE-EDMF --- physics/satmedmfvdifq.F | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index a891fa387..ea61924aa 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -241,7 +241,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) parameter(aphi5=5.,aphi16=16.) parameter(elmfac=1.0,elefac=1.0,cql=100.) - parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) + parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=3000.) parameter(qlcr=3.5e-5,zstblmax=2500.) parameter(xkinv1=0.15,xkinv2=0.3) parameter(h1=0.33333333,hcrinv=250.) From a3c4d52d586a25d5dbf13c629207c4e9c8439429 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:10:10 +0000 Subject: [PATCH 084/165] updated GFS surface layer scheme --- physics/sfc_diff.f | 129 ++++++++++++++++++++++++++++----------------- 1 file changed, 82 insertions(+), 47 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 93102e467..d5695319d 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,7 +61,7 @@ end subroutine sfc_diff_finalize !! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes. !! subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) - & ps,t1,q1,z1,wind, & !intent(in) + & ps,t1,q1,z1,garea,wind, & !intent(in) & prsl1,prslki,prsik1,prslk1, & !intent(in) & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) @@ -70,7 +70,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & wet,dry,icy, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) - & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) @@ -98,13 +97,12 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys), dimension(:), intent(in) :: u10m,v10m real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav real(kind=kind_phys), dimension(:), intent(in) :: & - & ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & + & ps,t1,q1,z1,garea,prsl1,prslki,prsik1,prslk1, & & wind,sigmaf,shdmax, & & z0pert,ztpert ! mg, sfc-perts real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & - & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snwdph_wat,snwdph_lnd,snwdph_ice + & tsurf_wat, tsurf_lnd, tsurf_ice real(kind=kind_phys), dimension(:), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(:), intent(inout) :: & @@ -125,14 +123,16 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! integer i ! - real(kind=kind_phys) :: rat, thv1, restar, wind10m, + real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, & czilc, tem1, tem2, virtfac - real(kind=kind_phys) :: tvs, z0, z0max, ztmax + real(kind=kind_phys) :: tvs, z0, z0max, ztmax, zvfun, gdx +! + real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 ! real(kind=kind_phys), parameter :: & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp - &, charnock=.014_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea + &, charnock=.018_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea &, zmin=1.0e-6_kp & &, vis=1.4e-5_kp, rnu=1.51e-5_kp, visi=one/vis & &, log01=log(0.01_kp), log05=log(0.05_kp), log07=log(0.07_kp) @@ -167,7 +167,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) do i=1,im if(flag_iter(i)) then virtfac = one + rvrdm1 * max(q1(i),qmin) - thv1 = t1(i) * prslki(i) * virtfac + tv1 = t1(i) * virtfac + thv1 = tv1 * prslki(i) + zvfun = zero + gdx = sqrt(garea(i)) ! compute stability dependent exchange coefficients ! this portion of the code is presently suppressed @@ -225,23 +228,34 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(z0max, zmin) -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8_kp - - tem1 = 1.0_kp - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) - +!! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil +! czilc = 0.8_kp +! tem1 = 1.0_kp - sigmaf(i) +! ztmax = z0max*exp( - tem1*tem1 +! & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) +! + czilc = 10.0_kp ** (- 4.0_kp * z0max) ! Trier et al. (2011,WAF) + czilc = min(czilc, 0.8_kp) + tem1 = 1.0_kp - sigmaf(i) + czilc = czilc * tem1 * tem1 + ztmax = z0max * exp( - czilc * ca + & * 258.2_kp * sqrt(ustar_lnd(i)*z0max) ) +! ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land if (ztpert(i) /= zero) then ztmax = ztmax * (10.0_kp**ztpert(i)) endif ztmax = max(ztmax, zmin) +! + tem1 = (z0max - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, zero), 1.0_kp) + tem2 = max(sigmaf(i), 0.1_kp) + zvfun = sqrt(tem1 * tem2) ! call stability ! --- inputs: - & (z1(i), snwdph_lnd(i), thv1, wind(i), + & (z1(i), zvfun, gdx, tv1, thv1, wind(i), & z0max, ztmax, tvs, grav, ! --- outputs: & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), @@ -265,18 +279,26 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(z0max, zmin) -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height +!! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height ! dependance of czil - czilc = 0.8_kp +! czilc = 0.8_kp - tem1 = 1.0_kp - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) +! tem1 = 1.0_kp - sigmaf(i) +! ztmax = z0max*exp( - tem1*tem1 +! & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) +! + czilc = 10.0_kp ** (- 4.0_kp * z0max) + czilc = min(czilc, 0.8_kp) + tem1 = 1.0_kp - sigmaf(i) + czilc = czilc * tem1 * tem1 + ztmax = z0max * exp( - czilc * ca + & * 258.2_kp * sqrt(ustar_ice(i)*z0max) ) +! ztmax = max(ztmax, 1.0e-6) ! call stability ! --- inputs: - & (z1(i), snwdph_ice(i), thv1, wind(i), + & (z1(i), zvfun, gdx, tv1, thv1, wind(i), & z0max, ztmax, tvs, grav, ! --- outputs: & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), @@ -290,7 +312,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac z0 = 0.01_kp * z0rl_wat(i) z0max = max(zmin, min(z0,z1(i))) - ustar_wat(i) = sqrt(grav * z0 / charnock) +! ustar_wat(i) = sqrt(grav * z0 / charnock) wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) !** test xubin's new z0 @@ -320,7 +342,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), snwdph_wat(i), thv1, wind(i), + & (z1(i), zvfun, gdx, tv1, thv1, wind(i), & z0max, ztmax, tvs, grav, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), @@ -330,7 +352,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! if (sfc_z0_type >= 0) then if (sfc_z0_type == 0) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + ! mbek -- toga-coare flux algorithm ! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) @@ -358,7 +383,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif elseif (z0rl_wav(i) <= 1.0e-7_kp) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) if (redrag) then z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) @@ -380,7 +407,7 @@ end subroutine sfc_diff_run !>\ingroup GFS_diff_main subroutine stability & ! --- inputs: - & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & + & ( z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav, & ! --- outputs: & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) !----- @@ -388,7 +415,7 @@ subroutine stability & integer, parameter :: kp = kind_phys ! --- inputs: real(kind=kind_phys), intent(in) :: & - & z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav + & z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav ! --- outputs: real(kind=kind_phys), intent(out) :: & @@ -397,27 +424,41 @@ subroutine stability & ! --- locals: real(kind=kind_phys), parameter :: alpha=5.0_kp, a0=-3.975_kp & &, a1=12.32_kp, alpha4=4.0_kp*alpha & - &, b1=-7.755_kp, b2=6.041_kp, alpha2=alpha+alpha & - &, beta=1.0_kp & + &, b1=-7.755_kp, b2=6.041_kp & + &, xkrefsqr=0.3_kp, xkmin=0.05_kp & + &, xkgdx=3000.0_kp & &, a0p=-7.941_kp, a1p=24.75_kp, b1p=-8.705_kp, b2p=7.899_kp& - &, ztmin1=-999.0_kp, zero=0.0_kp, one=1.0_kp + &, zolmin=-10.0_kp, zero=0.0_kp, one=1.0_kp real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & hl1, hl12, pm, ph, pm10, ph2, & z1i, & fms, fhs, hl0, hl0inf, hlinf, & hl110, hlt, hltinf, olinf, - & tem1, tem2, ztmax1 + & tem1, tem2, zolmax + + real(kind=kind_phys) xkzo z1i = one / z1 - tem1 = z0max/z1 - if (abs(one-tem1) > 1.0e-6_kp) then - ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) +! +! set background diffusivities with one for gdx >= xkgdx and +! as a function of horizontal grid size for gdx < xkgdx +! (i.e., gdx/xkgdx for gdx < xkgdx) +! + if(gdx >= xkgdx) then + xkzo = one else - ztmax1 = 99.0_kp + xkzo = gdx / xkgdx endif - if( z0max < 0.05_kp .and. snwdph < 10.0_kp ) ztmax1 = 99.0_kp + + tem1 = tv1 - tvs + if(tem1 > zero) then + tem2 = xkzo * zvfun + xkzo = min(max(tem2, xkmin), xkzo) + endif + + zolmax = xkrefsqr / sqrt(xkzo) ! compute stability indices (rb and hlinf) @@ -438,7 +479,7 @@ subroutine stability & fm10 = log((z0max+10.0_kp) * tem1) fh2 = log((ztmax+2.0_kp) * tem2) hlinf = rb * fm * fm / fh - hlinf = min(max(hlinf,ztmin1),ztmax1) + hlinf = min(max(hlinf,zolmin),zolmax) ! ! stable case ! @@ -457,7 +498,7 @@ subroutine stability & fms = fm - pm fhs = fh - ph hl1 = fms * fms * rb / fhs - hl1 = min(max(hl1, ztmin1), ztmax1) + hl1 = min(hl1, zolmax) endif ! ! second iteration @@ -472,11 +513,9 @@ subroutine stability & pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ph = bb0 - bb + log( (one+bb)/(one+bb0) ) hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) aa = sqrt(one + alpha4 * hl110) pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12,ztmin1),ztmax1) ! aa = sqrt(one + alpha4 * hl12) bb = sqrt(one + alpha4 * hl12) ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) @@ -488,7 +527,7 @@ subroutine stability & tem1 = 50.0_kp * z0max if(abs(olinf) <= tem1) then hlinf = -z1 / tem1 - hlinf = min(max(hlinf,ztmin1),ztmax1) + hlinf = max(hlinf, zolmin) endif ! ! get pm and ph @@ -498,10 +537,8 @@ subroutine stability & pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) else ! hlinf < 0.05 hl1 = -hlinf @@ -511,11 +548,9 @@ subroutine stability & ! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 ! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp ! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp ! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 endif From f16f1af56d14c2dec4a883f8583ac8a7bd48a0aa Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:13:27 +0000 Subject: [PATCH 085/165] updated sfc_diff.meta --- physics/sfc_diff.meta | 36 +++++++++--------------------------- 1 file changed, 9 insertions(+), 27 deletions(-) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 342eaeea5..0ec39aa5c 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -87,6 +87,15 @@ kind = kind_phys intent = in optional = F +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -304,33 +313,6 @@ kind = kind_phys intent = in optional = F -[snwdph_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [z0rl_wat] standard_name = surface_roughness_length_over_water long_name = surface roughness length over water (temporary use as interstitial) From 2a518b28c75f666396f326b958ffcfae09b270cf Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:17:41 +0000 Subject: [PATCH 086/165] add sea spray effect parameterization --- physics/sfc_nst.f | 53 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 50 insertions(+), 3 deletions(-) diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index f03e725f3..663276224 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -28,6 +28,7 @@ end subroutine sfc_nst_finalize subroutine sfc_nst_run & & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & + & lseaspray, fm, fm10, & & prsl1, prslki, prsik1, prslk1, wet, use_flake, xlon, & & sinlat, stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & @@ -47,6 +48,7 @@ subroutine sfc_nst_run & ! call sfc_nst ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! +! lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_flake, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! @@ -89,6 +91,10 @@ subroutine sfc_nst_run & ! tref - real, reference/foundation temperature ( k ) im ! ! cm - real, surface exchange coeff for momentum (m/s) im ! ! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! lseaspray- logical, .t. for parameterization for sea spray 1 ! +! fm - real, a stability profile function for momentum im ! +! fm10 - real, a stability profile function for momentum im ! +! at 10m ! ! prsl1 - real, surface layer mean pressure (pa) im ! ! prslki - real, im ! ! prsik1 - real, im ! @@ -189,12 +195,15 @@ subroutine sfc_nst_run & real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tref, cm, ch, prsl1, prslki, prsik1, prslk1, & - & xlon,xcosz, & + & t1, q1, tref, cm, ch, fm, fm10, & + & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind real (kind=kind_phys), intent(in) :: timestep real (kind=kind_phys), intent(in) :: solhr +! For sea spray effect + logical, intent(in) :: lseaspray +! logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet, & & use_flake ! &, icy @@ -245,6 +254,18 @@ subroutine sfc_nst_run & ! external functions called: iw3jdn integer :: iw3jdn +! +! parameters for sea spray effect +! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, + & bb1, hflxs, evaps, ptem +! +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, +! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, + & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 +! !====================================================================================================== cc ! Initialize CCPP error handling variables @@ -629,7 +650,33 @@ subroutine sfc_nst_run & endif enddo endif ! if ( nstf_name1 > 1 ) then - +! +! include sea spray effects +! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo ! do i=1,im if ( flag(i) ) then From 20189cbc29f374cf5f596d79c5aa2f9baa1b4207 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:19:26 +0000 Subject: [PATCH 087/165] updated sfc_nst.meta --- physics/sfc_nst.meta | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index a29f10f90..08dde266f 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -195,6 +195,32 @@ kind = kind_phys intent = in optional = F +[lseaspray] + standard_name = flag_for_sea_spray + long_name = flag for sea spray parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water + long_name = Monin-Obukhov similarity function for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water + long_name = Monin-Obukhov similarity parameter for momentum at 10m over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = surface layer mean pressure From 3d1e7f3b0d2fedac9a0cc1afe7466e1239777c12 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:21:45 +0000 Subject: [PATCH 088/165] add sea spray effect parameterization --- physics/sfc_ocean.F | 97 +++++++++++++++++++++++++++++++++++++-------- 1 file changed, 81 insertions(+), 16 deletions(-) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 67a6df04f..3f0fd23bc 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -26,8 +26,9 @@ end subroutine sfc_ocean_finalize subroutine sfc_ocean_run & !................................... ! --- inputs: - & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & - & tskin, cm, ch, prsl1, prslki, wet, use_flake, wind, &, ! --- inputs + & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & + & tskin, cm, ch, lseaspray, fm, fm10, & + & prsl1, prslki, wet, use_flake, wind, &, ! --- inputs & flag_iter, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -40,8 +41,7 @@ subroutine sfc_ocean_run & ! ! ! call sfc_ocean ! ! inputs: ! -! ( im, ps, t1, q1, tskin, cm, ch, ! -!! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! +! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_flake, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! @@ -65,11 +65,16 @@ subroutine sfc_ocean_run & ! inputs: size ! ! im - integer, horizontal dimension 1 ! ! ps - real, surface pressure im ! +! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! ! cm - real, surface exchange coeff for momentum (m/s) im ! ! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! lseaspray- logical, .t. for parameterization for sea spray 1 ! +! fm - real, a stability profile function for momentum im ! +! fm10 - real, a stability profile function for momentum im ! +! at 10m ! ! prsl1 - real, surface layer mean pressure im ! ! prslki - real, im ! ! wet - logical, =T if any ocean/lak, =F otherwise im ! @@ -97,11 +102,14 @@ subroutine sfc_ocean_run & &, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - real (kind=kind_phys), intent(in) :: rd, eps, epsm1, rvrdm1 + real (kind=kind_phys), intent(in) :: hvap, cp, rd, eps, epsm1, rvrdm1 - real (kind=kind_phys), dimension(:), intent(in) :: ps, & - & t1, q1, tskin, cm, ch, prsl1, prslki, wind + real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & + & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind +! For sea spray effect + logical, intent(in) :: lseaspray +! logical, dimension(:), intent(in) :: flag_iter, wet, use_flake ! --- outputs: @@ -113,48 +121,105 @@ subroutine sfc_ocean_run & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, tem + real (kind=kind_phys) :: qss, rch, tem, + & elocp, cpinv, hvapi + real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i + logical :: flag(im) +! +! parameters for sea spray effect +! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, + & bb1, hflxs, evaps, ptem +! +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, +! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, + & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 +! +!====================================================================================================== !===> ... begin here ! ! -- ... initialize CCPP error handling variables errmsg = '' errflg = 0 + + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp ! ! --- ... flag for open water do i = 1, im - + flag(i) = (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) ! --- ... initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface - if (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) then - q0 = max( q1(i), qmin ) - rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) + if ( flag(i) ) then + q0(i) = max( q1(i), qmin ) + rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) qss = fpvs( tskin(i) ) qss = eps*qss / (ps(i) + epsm1*qss) ! --- ... rcp = rho cp ch v + rch = rho(i) * cp * ch(i) * wind(i) tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - chh(i) = rho * tem + chh(i) = rho(i) * tem ! --- ... sensible and latent heat flux over open water - hflx(i) = tem * (tskin(i) - t1(i) * prslki(i)) + hflx(i) = rch * (tskin(i) - t1(i) * prslki(i)) - evap(i) = tem * (qss - q0) + evap(i) = elocp * rch * (qss - q0(i)) - ep(i) = evap(i) qsurf(i) = qss gflux(i) = zero endif enddo ! +! include sea spray effects +! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo +! + do i = 1, im + if ( flag(i) ) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + ep(i) = evap(i) + endif + enddo +! + return !................................... end subroutine sfc_ocean_run From f4bdbf5ce883c98a6764737c89c3139020774d32 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:24:07 +0000 Subject: [PATCH 089/165] updated sfc_ocean.meta --- physics/sfc_ocean.meta | 62 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f27c2207d..0fcc4e646 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -15,6 +15,24 @@ type = integer intent = in optional = F +[hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [rd] standard_name = gas_constant_dry_air long_name = ideal gas constant for dry air @@ -60,6 +78,24 @@ kind = kind_phys intent = in optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = x component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = y component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = surface layer mean temperature @@ -105,6 +141,32 @@ kind = kind_phys intent = in optional = F +[lseaspray] + standard_name = flag_for_sea_spray + long_name = flag for sea spray parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water + long_name = Monin-Obukhov similarity function for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water + long_name = Monin-Obukhov similarity parameter for momentum at 10m over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = surface layer mean pressure From f20791979152db0d4a2e41f3f8cfbad12037ce4b Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:26:21 +0000 Subject: [PATCH 090/165] updated heat & evap --- physics/shalcnv.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 7986d28f8..b1a5332ed 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -351,8 +351,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -360,7 +360,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From 9b889271cc704aa0a3a4dc398933cfbbfd088a25 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:29:15 +0000 Subject: [PATCH 091/165] updated heat & evap --- physics/shinhongvdif.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/shinhongvdif.meta b/physics/shinhongvdif.meta index 6b12b64f5..e7d1baccc 100644 --- a/physics/shinhongvdif.meta +++ b/physics/shinhongvdif.meta @@ -265,8 +265,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -274,7 +274,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From baaaf6b4a4e551d6feefff033c97e39401f8c460 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 21 May 2021 18:31:39 +0000 Subject: [PATCH 092/165] updated heat & evap --- physics/ysuvdif.meta | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index 1ee952d45..ed8ada624 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -292,8 +292,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation units = K m s-1 dimensions = (horizontal_loop_extent) type = real @@ -301,7 +301,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) From 16a71292056fd84ee2597203836b391fc8c343bd Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Mon, 24 May 2021 02:31:53 +0000 Subject: [PATCH 093/165] updated TKE-EDMF --- physics/satmedmfvdifq.F | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index ea61924aa..f6ab554ca 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -150,8 +150,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & phih(im), phim(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), -! & ust3(im), wst3(im), rho_a(im), - & ust3(im), wst3(im), + & ust3(im), wst3(im), rho_a(im), & z0(im), crb(im), & hgamt(im), hgamq(im), & wscale(im),vpert(im), @@ -380,7 +379,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !> - Some output variables and logical flags are initialized do i = 1,im z0(i) = 0.01 * zorl(i) -! rho_a(i) = prsl(i,1) / (rd * t1(i,1)) + rho_a(i) = prsl(i,1) / (rd * t1(i,1)) dusfc(i) = 0. dvsfc(i) = 0. dtsfc(i) = 0. @@ -1480,14 +1479,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend 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 +! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend +! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo -! do i = 1,im -! dtsfc(i) = rho_a(i) * cp * heat(i) -! dqsfc(i) = rho_a(i) * hvap * evap(i) -! enddo + do i = 1,im + dtsfc(i) = rho_a(i) * cp * heat(i) + dqsfc(i) = rho_a(i) * hvap * evap(i) + enddo ! if(ldiag3d .and. .not. gen_tend) then do k = 1,km @@ -1619,14 +1618,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(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 +! dusfc(i) = dusfc(i)+conw*del(i,k)*utend +! dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo -! do i = 1,im -! dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) -! dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) -! enddo + do i = 1,im + dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + enddo ! if(ldiag3d .and. .not. gen_tend) then do k = 1,km From 5f7d6970b7d420601dc86c2db91d953feebe1a7b Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 24 May 2021 16:56:23 +0000 Subject: [PATCH 094/165] Added logistic function to damp the LW flux adjustment with height --- physics/dcyc2.f | 64 ++++++++++++++++++++++++---------------------- physics/dcyc2.meta | 26 +++++++++++++++++++ 2 files changed, 60 insertions(+), 30 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index f671cf1f2..09c80a97e 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -178,10 +178,10 @@ subroutine dcyc2t3_run & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & - & dry, icy, wet, minGPtemp, maxGPtemp, & - & minGPpres, use_LW_jacobian, sfculw, fluxlwUP_jac, & - & t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, flux2D_lwDOWN, & - & pert_radtend, do_sppt,ca_global, & + & dry, icy, wet, minGPtemp, maxGPtemp, damp_LW_fluxadj, & + & lfnc_k_grad, lfnc_p0, minGPpres, use_LW_jacobian, sfculw, & + & fluxlwUP_jac, t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, & + & flux2D_lwDOWN, pert_radtend, do_sppt,ca_global, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: & dtdt,dtdtnp,htrlw, & @@ -213,11 +213,12 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(:), intent(in) :: dry, icy, wet - logical, intent(in) :: use_LW_jacobian, pert_radtend + logical, intent(in) :: use_LW_jacobian, damp_LW_fluxadj, & + & pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres, & - & minGPtemp, maxGPtemp + & deltim, fhswr, minGPpres, minGPtemp, maxGPtemp, lfnc_k_grad, & + & lfnc_p0 real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & @@ -259,10 +260,11 @@ subroutine dcyc2t3_run & & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 - real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,c1,c2,c3,c4,c5,ku - ! Pressure limit for LW flux adjustment + real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,c1,c2,c3,c4,c5, & + & dP,lfnc + ! Length scale for flux-adjustment scaling real(kind=kind_phys), parameter :: & - & plim_fluxAdj_upper = 10000. + & L = 1. ! Scaling factor for downwelling LW Jacobian profile. real(kind=kind_phys), parameter :: & & c0 = 0.2 @@ -393,34 +395,36 @@ subroutine dcyc2t3_run & ! J_dn_sfc / J_up_sfc = scaling_factor ! J_dn_toa / J_up_sfc = 0 ! + ! Optionally, the flux adjustment can be damped with height using a logistic function + ! fx ~ L / (1 + exp(-k*dp)), where dp = p - p0 + ! L = 1, fix scale between 0-1. + ! k (steepness) and p0 (midpoint) are controlled via namelist do i = 1, im c1 = fluxlwUP_jac(i,iSFC) c2 = fluxlwUP_jac(i,iTOA) / c1 c3 = t_lev2(i,iSFC) - t_lev(i,iSFC) do k = 1, levs ! Only apply the Jacobian adjustment below plim_fluxAdj_upper - if (p_lev(i,k) .gt. plim_fluxAdj_upper) then - c4 = fluxlwUP_jac(i,k)/c1 - fluxlwnet = (flux2D_lwUP(i,k+1) - flux2D_lwUP(i,k) -& - & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) - ! (Eq. 9) - c5 = c0 * (c4 - c2) / (1 - c2) - ! (Eq. 10) - fluxlwnet_adj = fluxlwnet + c3*(c4-c5) - ! Compute adjusted heating rate - htrlw(i,k) = fluxlwnet_adj * con_g / & - & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) - - ! Store vertical index for plim_fluxAdj_upper - ku = k - ! Above, offset the heating rate by he same amount as in plim_fluxAdj_upper + c4 = fluxlwUP_jac(i,k)/c1 + fluxlwnet = (flux2D_lwUP(i,k+1) - flux2D_lwUP(i,k) - & + & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) + ! (Eq. 9) + c5 = c0 * (c4 - c2) / (1 - c2) + ! (Eq. 10) + fluxlwnet_adj = fluxlwnet + c3*(c4-c5) + ! Compute adjusted heating rate + htrlw(i,k) = fluxlwnet_adj * con_g / & + & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) + + ! Add radiative heating rates to physics heating rate. Optionally, scaled w/ height + ! using a logistic function + if (damp_LW_fluxadj) then + dp = p_lev(i,k) - lfnc_p0 + lfnc = L / (1+exp(-lfnc_k_grad*exp(1.)*dp/lfnc_p0)) else - htrlw(i,k) = hlw(i,k)+(p_lev(i,k)/plim_fluxAdj_upper)*& - & (htrlw(i,ku)-hlw(i,ku)) + lfnc = 1. endif - - ! Add radiative heating rates to physics heating rate - dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k) + dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k)*lfnc enddo enddo else diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 25b06cc83..dceb9ce77 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -388,6 +388,32 @@ type = logical intent = in optional = F +[damp_LW_fluxadj] + standard_name = flag_to_damp_RRTMGP_LW_jacobian_flux_adjustment + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lfnc_k_grad] + standard_name = steepness_of_flux_damping + long_name = steepness of logistic function for damping the LW flux adjustment + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lfnc_p0] + standard_name = midpoint_used_for_flux_damping + long_name = midpoint for damping the LW flux adjustment + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [sfculw] standard_name = surface_upwelling_longwave_flux_on_radiation_time_step long_name = total sky sfc upward lw flux From e9bdebdf6ae4bb0bae6ddeb0b0487de59fda01eb Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Mon, 24 May 2021 17:10:53 +0000 Subject: [PATCH 095/165] Add 3D diagnostics from thompson --- physics/module_mp_thompson.F90 | 19 ++++++++++++++++--- physics/mp_thompson.F90 | 11 +++++++---- physics/mp_thompson.meta | 13 +++++++++++++ 3 files changed, 36 insertions(+), 7 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index dfe31f375..af09ab58f 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1018,7 +1018,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims - errmsg, errflg, reset) + errmsg, errflg, reset, vts1) implicit none @@ -1028,6 +1028,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & its,ite, jts,jte, kts,kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & qv, qc, qr, qi, qs, qg, ni, nr + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: vts1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & tt, th REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(IN):: & @@ -1067,6 +1069,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ + REAL, DIMENSION(kts:kte):: vtsk1 + REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte):: & @@ -1260,6 +1264,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + vtsk1(k) = 0. + vts1(i,k,j) = 0. enddo if (is_aerosol_aware) then do k = kts, kte @@ -1283,7 +1289,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j) + kts, kte, dt, i, j, vtsk1) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1337,6 +1343,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg(i,k,j) = qg1d(k) ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) + vts1(i,k,j) = vtsk1(k) if (present(tt)) then; tt(i,k,j) = t1d(k) else @@ -1550,7 +1557,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rainprod, evapprod, & #endif rand1, rand2, rand3, & - kts, kte, dt, ii, jj) + kts, kte, dt, ii, jj, vtsk1) #ifdef MPI use mpi #endif @@ -1565,6 +1572,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 + REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & @@ -3362,6 +3370,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtgk(k) = 0. vtck(k) = 0. vtnck(k) = 0. + vtsk1(k) = 0. enddo if (ANY(L_qr .eqv. .true.)) then @@ -3469,6 +3478,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nstep = 0 do k = kte, kts, -1 vts = 0. + vtsk1(k)=0. if (rs(k).gt. R1) then xDs = smoc(k) / smob(k) @@ -3487,11 +3497,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + vtsk1(k)=vtsk(k) else vtsk(k) = vts*vts_boost(k) + vtsk1(k)=vtsk(k) endif else vtsk(k) = vtsk(k+1) + vtsk1(k)=0 endif if (vtsk(k) .gt. 1.E-3) then diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1ad4b2d4b..4767dfd2a 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -333,7 +333,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm, reset, do_radar_ref, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - errmsg, errflg) + errmsg, errflg,naux3d, aux3d) implicit none @@ -390,6 +390,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg + ! Auxillary output + integer, intent(in) :: naux3d + real(kind_phys), intent(inout) :: aux3d(:,:,:) ! Local variables @@ -606,7 +609,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -624,7 +627,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) end if end if if (errflg/=0) return @@ -655,7 +658,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ice = ice + max(0.0, delta_ice_mp/1000.0_kind_phys) snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) - + aux3d(:,:,1) = vts1 end subroutine mp_thompson_run !>@} diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 237890024..38b3b8dce 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -319,6 +319,19 @@ type = integer intent = out optional = F +[naux3d] + standard_name = number_of_3d_auxiliary_arrays + long_name = number of 3d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[aux3d] + standard_name = auxiliary_3d_arrays + long_name = auxiliary 3d arrays to output (for debugging) + units = none + dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys ######################################################################## [ccpp-arg-table] From 0600c16d18b20b0cb744290a9a8bdd4f898460a3 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Mon, 24 May 2021 17:29:01 +0000 Subject: [PATCH 096/165] Revert to assumed-shape array specification. See PR #664. --- physics/GFS_surface_generic.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 1c4854bb0..46117ff30 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -223,7 +223,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, integer, intent(in) :: im logical, intent(in) :: cplflx, cplchm, cplwav, lssav - logical, dimension(im), intent(in) :: icy, wet + logical, dimension(:), intent(in) :: icy, wet real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(:), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & From 2f6e70814fdaae4ba33b00c7d5c7ec421a8e69e8 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Mon, 24 May 2021 17:37:55 +0000 Subject: [PATCH 097/165] Reorganized RRTMGP aerosol optics. --- ...tics.F90 => GFS_rrtmgp_aerosol_optics.F90} | 66 ++++--- ...cs.meta => GFS_rrtmgp_aerosol_optics.meta} | 50 ++--- physics/rrtmgp_lw_aerosol_optics.meta | 173 ------------------ physics/rrtmgp_sw_aerosol_optics.F90 | 119 ------------ 4 files changed, 73 insertions(+), 335 deletions(-) rename physics/{rrtmgp_lw_aerosol_optics.F90 => GFS_rrtmgp_aerosol_optics.F90} (59%) rename physics/{rrtmgp_sw_aerosol_optics.meta => GFS_rrtmgp_aerosol_optics.meta} (91%) delete mode 100644 physics/rrtmgp_lw_aerosol_optics.meta delete mode 100644 physics/rrtmgp_sw_aerosol_optics.F90 diff --git a/physics/rrtmgp_lw_aerosol_optics.F90 b/physics/GFS_rrtmgp_aerosol_optics.F90 similarity index 59% rename from physics/rrtmgp_lw_aerosol_optics.F90 rename to physics/GFS_rrtmgp_aerosol_optics.F90 index df0e77163..194c33ba1 100644 --- a/physics/rrtmgp_lw_aerosol_optics.F90 +++ b/physics/GFS_rrtmgp_aerosol_optics.F90 @@ -1,8 +1,8 @@ -module rrtmgp_lw_aerosol_optics +module GFS_rrtmgp_aerosol_optics use machine, only: kind_phys use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl - use radiation_tools, only: check_error_msg + use mo_optical_props, only: ty_optical_props_1scl,ty_optical_props_2str + use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props use module_radiation_aerosols, only: & @@ -14,34 +14,37 @@ module rrtmgp_lw_aerosol_optics implicit none - public rrtmgp_lw_aerosol_optics_init, rrtmgp_lw_aerosol_optics_run, rrtmgp_lw_aerosol_optics_finalize + public GFS_rrtmgp_aerosol_optics_init, GFS_rrtmgp_aerosol_optics_run, GFS_rrtmgp_aerosol_optics_finalize contains ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_init() + ! SUBROUTINE GFS_rrtmgp_aerosol_optics_init() ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_init() - end subroutine rrtmgp_lw_aerosol_optics_init + subroutine GFS_rrtmgp_aerosol_optics_init() + end subroutine GFS_rrtmgp_aerosol_optics_init ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_run() + ! SUBROUTINE GFS_rrtmgp_aerosol_optics_run() ! ######################################################################################### -!! \section arg_table_rrtmgp_lw_aerosol_optics_run -!! \htmlinclude rrtmgp_lw_aerosol_optics.html +!! \section arg_table_GFS_rrtmgp_aerosol_optics_run +!! \htmlinclude GFS_rrtmgp_aerosol_optics.html !! - subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer,& - p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, lw_optical_props_aerosol, errmsg, errflg) + subroutine GFS_rrtmgp_aerosol_optics_run(doLWrad, nCol, nLev, nDay, nTracer, nTracerAer, & + idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, lw_optical_props_aerosol, sw_optical_props_aerosol, errmsg, errflg) ! Inputs logical, intent(in) :: & doLWrad ! Logical flag for longwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal grid points + nDay, & ! Number of daylit points nLev, & ! Number of vertical layers nTracer, & ! Number of tracers nTracerAer ! Number of aerosol tracers + integer,intent(in),dimension(:) :: & + idxday ! Daylit point indices real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat, & ! Latitude @@ -63,6 +66,8 @@ subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer aerodp ! Vertical integrated optical depth for various aerosol species type(ty_optical_props_1scl),intent(inout) :: & lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + type(ty_optical_props_2str),intent(out) :: & + sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,omega) integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & @@ -82,23 +87,40 @@ subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer if (.not. doLWrad) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, ncol, nLev, & - nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) + call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, & + lat, ncol, nLev, nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) - ! Copy aerosol optical information to RRTMGP DDT + ! Copy aerosol optical information to RRTMGP DDTs + ! + ! LW + ! lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) - lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() do iBand=1,lw_gas_props%get_nband() lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand lw_optical_props_aerosol%gpt2band(iBand) = iBand end do + ! + ! SW + ! + if (nDay .gt. 0) then + ! Allocate RRTMGP DDT + call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & + nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) + ! Copy + sw_optical_props_aerosol%tau(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 1) + sw_optical_props_aerosol%tau(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,1) + sw_optical_props_aerosol%ssa(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 2) + sw_optical_props_aerosol%ssa(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,2) + sw_optical_props_aerosol%g(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 3) + sw_optical_props_aerosol%g(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,3) + endif - end subroutine rrtmgp_lw_aerosol_optics_run + end subroutine GFS_rrtmgp_aerosol_optics_run ! ######################################################################################### - ! SUBROUTINE rrtmgp_lw_aerosol_optics_finalize() + ! SUBROUTINE GFS_rrtmgp_aerosol_optics_finalize() ! ######################################################################################### - subroutine rrtmgp_lw_aerosol_optics_finalize() - end subroutine rrtmgp_lw_aerosol_optics_finalize -end module rrtmgp_lw_aerosol_optics + subroutine GFS_rrtmgp_aerosol_optics_finalize() + end subroutine GFS_rrtmgp_aerosol_optics_finalize +end module GFS_rrtmgp_aerosol_optics diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/GFS_rrtmgp_aerosol_optics.meta similarity index 91% rename from physics/rrtmgp_sw_aerosol_optics.meta rename to physics/GFS_rrtmgp_aerosol_optics.meta index f4909c794..aa7f6d4a5 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/GFS_rrtmgp_aerosol_optics.meta @@ -1,15 +1,15 @@ [ccpp-table-properties] - name = rrtmgp_sw_aerosol_optics + name = GFS_rrtmgp_aerosol_optics type = scheme dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 ######################################################################## [ccpp-arg-table] - name = rrtmgp_sw_aerosol_optics_run + name = GFS_rrtmgp_aerosol_optics_run type = scheme -[doSWrad] - standard_name = flag_to_calc_sw - long_name = logical flags for sw radiation calls +[doLWrad] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls units = flag dimensions = () type = logical @@ -23,6 +23,22 @@ type = integer intent = in optional = F +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F [nLev] standard_name = vertical_dimension long_name = number of vertical levels @@ -47,22 +63,6 @@ type = integer intent = in optional = F -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure at vertical interface for radiation calculation @@ -162,6 +162,14 @@ kind = kind_phys intent = inout optional = F +[lw_optical_props_aerosol] + standard_name = longwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_1scl + intent = inout + optional = F [sw_optical_props_aerosol] standard_name = shortwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta deleted file mode 100644 index ad68fd546..000000000 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ /dev/null @@ -1,173 +0,0 @@ -[ccpp-table-properties] - name = rrtmgp_lw_aerosol_optics - type = scheme - dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 - -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_aerosol_optics_run - type = scheme -[doLWrad] - standard_name = flag_to_calc_lw - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ncol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[nLev] - standard_name = vertical_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in - optional = F -[nTracer] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[nTracerAer] - standard_name = number_of_aerosol_tracers_MG - long_name = number of aerosol tracers for Morrison Gettelman MP - units = count - dimensions = () - type = integer - intent = in - optional = F -[p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa - long_name = air pressure at vertical interface for radiation calculation - units = hPa - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[p_lay] - standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa - long_name = air pressure at vertical layer for radiation calculation - units = hPa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[p_lk] - standard_name = dimensionless_exner_function_at_model_layers - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[tv_lay] - standard_name = virtual_temperature - long_name = layer virtual temperature - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[relhum] - standard_name = relative_humidity - long_name = layer relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[lsmask] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tracer] - standard_name = chemical_tracers - long_name = chemical tracers - units = g g-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[aerfld] - standard_name = aerosol_number_concentration_from_gocart_aerosol_climatology - long_name = GOCART aerosol climatology number concentration - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_aerosol_tracers_MG) - type = real - kind = kind_phys - intent = in - optional = F -[lon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[aerodp] - standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles - long_name = vertical integrated optical depth for various aerosol species - units = none - dimensions = (horizontal_loop_extent,number_of_species_for_aerosol_optical_depth) - type = real - kind = kind_phys - intent = inout - optional = F -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/rrtmgp_sw_aerosol_optics.F90 b/physics/rrtmgp_sw_aerosol_optics.F90 deleted file mode 100644 index 3a74771b7..000000000 --- a/physics/rrtmgp_sw_aerosol_optics.F90 +++ /dev/null @@ -1,119 +0,0 @@ -module rrtmgp_sw_aerosol_optics - use machine, only: kind_phys - use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_2str - use radiation_tools, only: check_error_msg - use rrtmgp_sw_gas_optics, only: sw_gas_props - use rrtmgp_lw_gas_optics, only: lw_gas_props - use module_radiation_aerosols, only: & - NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) - NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) - setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) - NSPC1 ! Number of species for vertically integrated aerosol optical-depth - use netcdf - - implicit none - - public rrtmgp_sw_aerosol_optics_init, rrtmgp_sw_aerosol_optics_run, rrtmgp_sw_aerosol_optics_finalize - -contains - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_init() - ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_init() - end subroutine rrtmgp_sw_aerosol_optics_init - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_run() - ! ######################################################################################### -!! \section arg_table_rrtmgp_sw_aerosol_optics_run -!! \htmlinclude rrtmgp_sw_aerosol_optics_run.html -!! - subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer, nDay, & - idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, sw_optical_props_aerosol, errmsg, errflg ) - - ! Inputs - logical, intent(in) :: & - doSWrad ! Logical flag for shortwave radiation call - integer, intent(in) :: & - nCol, & ! Number of horizontal grid points - nDay, & ! Number of daylit points - nLev, & ! Number of vertical layers - nTracer, & ! Number of tracers - nTracerAer ! Number of aerosol tracers - integer,intent(in),dimension(:) :: & - idxday ! Indices for daylit points. - real(kind_phys), dimension(:), intent(in) :: & - lon, & ! Longitude - lat, & ! Latitude - lsmask ! Land/sea/sea-ice mask - real(kind_phys), dimension(:,:),intent(in) :: & - p_lay, & ! Pressure @ layer-centers (Pa) - tv_lay, & ! Virtual-temperature @ layer-centers (K) - relhum, & ! Relative-humidity @ layer-centers - p_lk ! Exner function @ layer-centers (1) - real(kind_phys), dimension(:, :,:),intent(in) :: & - tracer ! trace gas concentrations - real(kind_phys), dimension(:, :,:),intent(in) :: & - aerfld ! aerosol input concentrations - real(kind_phys), dimension(:,:),intent(in) :: & - p_lev ! Pressure @ layer-interfaces (Pa) - - ! Outputs - real(kind_phys), dimension(:,:), intent(inout) :: & - aerodp ! Vertical integrated optical depth for various aerosol species - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - integer, intent(out) :: & - errflg ! CCPP error flag - character(len=*), intent(out) :: & - errmsg ! CCPP error message - - ! Local variables - real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & - aerosolslw ! - real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & - aerosolssw, aerosolssw2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. doSWrad) return - if (nDay .gt. 0) then - - ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & - nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) - - ! Store aerosol optical properties - ! SW. - ! For RRTMGP SW the bands are now ordered from [IR(band) -> nIR -> UV], in RRTMG the - ! band ordering was [nIR -> UV -> IR(band)] - aerosolssw(1:nCol,:,1,1) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),1) - aerosolssw(1:nCol,:,1,2) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),2) - aerosolssw(1:nCol,:,1,3) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),3) - aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),1) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,1) - aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),2) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,2) - aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) - - ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] - call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & - nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) - - ! Copy aerosol optical information to RRTMGP DDT - sw_optical_props_aerosol%tau = aerosolssw(idxday(1:nday),:,:,1) - sw_optical_props_aerosol%ssa = aerosolssw(idxday(1:nday),:,:,2) - sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) - endif - - end subroutine rrtmgp_sw_aerosol_optics_run - - ! ######################################################################################### - ! SUBROUTINE rrtmgp_sw_aerosol_optics_finalize() - ! ######################################################################################### - subroutine rrtmgp_sw_aerosol_optics_finalize() - end subroutine rrtmgp_sw_aerosol_optics_finalize -end module rrtmgp_sw_aerosol_optics From 3932db1b37fd04f86bc8552b13f999298e2e919a Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Tue, 25 May 2021 13:34:09 +0000 Subject: [PATCH 098/165] correction: add vts to additional calls and aux,naux to correct place in meta file --- physics/mp_thompson.F90 | 7 +++++-- physics/mp_thompson.meta | 26 +++++++++++++------------- 2 files changed, 18 insertions(+), 15 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 4767dfd2a..ab9f49049 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -431,6 +431,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + !Auxillary fields + real(kind_phys) :: vts1(1:ncol,1:nlev) + ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -569,7 +572,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -588,7 +591,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) end if else if (do_effective_radii) then diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 38b3b8dce..a6810e203 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -319,19 +319,6 @@ type = integer intent = out optional = F -[naux3d] - standard_name = number_of_3d_auxiliary_arrays - long_name = number of 3d auxiliary arrays to output (for debugging) - units = count - dimensions = () - type = integer -[aux3d] - standard_name = auxiliary_3d_arrays - long_name = auxiliary 3d arrays to output (for debugging) - units = none - dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys ######################################################################## [ccpp-arg-table] @@ -705,6 +692,19 @@ type = integer intent = out optional = F +[naux3d] + standard_name = number_of_3d_auxiliary_arrays + long_name = number of 3d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer +[aux3d] + standard_name = auxiliary_3d_arrays + long_name = auxiliary 3d arrays to output (for debugging) + units = none + dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) + type = real + kind = kind_phys ######################################################################## [ccpp-arg-table] From 7bc877dd5e69cf0f171b1267cf0776fa33d6fb48 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 25 May 2021 16:47:28 +0000 Subject: [PATCH 099/165] Revert "Reorganized RRTMGP aerosol optics." This reverts commit 2f6e70814fdaae4ba33b00c7d5c7ec421a8e69e8. --- ...ptics.F90 => rrtmgp_lw_aerosol_optics.F90} | 66 +++---- physics/rrtmgp_lw_aerosol_optics.meta | 173 ++++++++++++++++++ physics/rrtmgp_sw_aerosol_optics.F90 | 119 ++++++++++++ ...ics.meta => rrtmgp_sw_aerosol_optics.meta} | 50 +++-- 4 files changed, 335 insertions(+), 73 deletions(-) rename physics/{GFS_rrtmgp_aerosol_optics.F90 => rrtmgp_lw_aerosol_optics.F90} (59%) create mode 100644 physics/rrtmgp_lw_aerosol_optics.meta create mode 100644 physics/rrtmgp_sw_aerosol_optics.F90 rename physics/{GFS_rrtmgp_aerosol_optics.meta => rrtmgp_sw_aerosol_optics.meta} (91%) diff --git a/physics/GFS_rrtmgp_aerosol_optics.F90 b/physics/rrtmgp_lw_aerosol_optics.F90 similarity index 59% rename from physics/GFS_rrtmgp_aerosol_optics.F90 rename to physics/rrtmgp_lw_aerosol_optics.F90 index 194c33ba1..df0e77163 100644 --- a/physics/GFS_rrtmgp_aerosol_optics.F90 +++ b/physics/rrtmgp_lw_aerosol_optics.F90 @@ -1,8 +1,8 @@ -module GFS_rrtmgp_aerosol_optics +module rrtmgp_lw_aerosol_optics use machine, only: kind_phys use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp - use mo_optical_props, only: ty_optical_props_1scl,ty_optical_props_2str - use radiation_tools, only: check_error_msg + use mo_optical_props, only: ty_optical_props_1scl + use radiation_tools, only: check_error_msg use rrtmgp_sw_gas_optics, only: sw_gas_props use rrtmgp_lw_gas_optics, only: lw_gas_props use module_radiation_aerosols, only: & @@ -14,37 +14,34 @@ module GFS_rrtmgp_aerosol_optics implicit none - public GFS_rrtmgp_aerosol_optics_init, GFS_rrtmgp_aerosol_optics_run, GFS_rrtmgp_aerosol_optics_finalize + public rrtmgp_lw_aerosol_optics_init, rrtmgp_lw_aerosol_optics_run, rrtmgp_lw_aerosol_optics_finalize contains ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_aerosol_optics_init() + ! SUBROUTINE rrtmgp_lw_aerosol_optics_init() ! ######################################################################################### - subroutine GFS_rrtmgp_aerosol_optics_init() - end subroutine GFS_rrtmgp_aerosol_optics_init + subroutine rrtmgp_lw_aerosol_optics_init() + end subroutine rrtmgp_lw_aerosol_optics_init ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_aerosol_optics_run() + ! SUBROUTINE rrtmgp_lw_aerosol_optics_run() ! ######################################################################################### -!! \section arg_table_GFS_rrtmgp_aerosol_optics_run -!! \htmlinclude GFS_rrtmgp_aerosol_optics.html +!! \section arg_table_rrtmgp_lw_aerosol_optics_run +!! \htmlinclude rrtmgp_lw_aerosol_optics.html !! - subroutine GFS_rrtmgp_aerosol_optics_run(doLWrad, nCol, nLev, nDay, nTracer, nTracerAer, & - idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & - aerodp, lw_optical_props_aerosol, sw_optical_props_aerosol, errmsg, errflg) + subroutine rrtmgp_lw_aerosol_optics_run(doLWrad, nCol, nLev, nTracer, nTracerAer,& + p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, lw_optical_props_aerosol, errmsg, errflg) ! Inputs logical, intent(in) :: & doLWrad ! Logical flag for longwave radiation call integer, intent(in) :: & nCol, & ! Number of horizontal grid points - nDay, & ! Number of daylit points nLev, & ! Number of vertical layers nTracer, & ! Number of tracers nTracerAer ! Number of aerosol tracers - integer,intent(in),dimension(:) :: & - idxday ! Daylit point indices real(kind_phys), dimension(:), intent(in) :: & lon, & ! Longitude lat, & ! Latitude @@ -66,8 +63,6 @@ subroutine GFS_rrtmgp_aerosol_optics_run(doLWrad, nCol, nLev, nDay, nTracer, nTr aerodp ! Vertical integrated optical depth for various aerosol species type(ty_optical_props_1scl),intent(inout) :: & lw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) - type(ty_optical_props_2str),intent(out) :: & - sw_optical_props_aerosol ! RRTMGP DDT: Shortwave aerosol optical properties (tau,ssa,omega) integer, intent(out) :: & errflg ! CCPP error flag character(len=*), intent(out) :: & @@ -87,40 +82,23 @@ subroutine GFS_rrtmgp_aerosol_optics_run(doLWrad, nCol, nLev, nDay, nTracer, nTr if (.not. doLWrad) return ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile - call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, & - lat, ncol, nLev, nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) + call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, ncol, nLev, & + nLev+1, .true., .true., aerosolssw, aerosolslw, aerodp) - ! Copy aerosol optical information to RRTMGP DDTs - ! - ! LW - ! + ! Copy aerosol optical information to RRTMGP DDT lw_optical_props_aerosol%tau = aerosolslw(:,:,:,1) * (1. - aerosolslw(:,:,:,2)) + lw_optical_props_aerosol%band_lims_wvn = lw_gas_props%get_band_lims_wavenumber() do iBand=1,lw_gas_props%get_nband() lw_optical_props_aerosol%band2gpt(1:2,iBand) = iBand lw_optical_props_aerosol%gpt2band(iBand) = iBand end do - ! - ! SW - ! - if (nDay .gt. 0) then - ! Allocate RRTMGP DDT - call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & - nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) - ! Copy - sw_optical_props_aerosol%tau(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 1) - sw_optical_props_aerosol%tau(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,1) - sw_optical_props_aerosol%ssa(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 2) - sw_optical_props_aerosol%ssa(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,2) - sw_optical_props_aerosol%g(:,:,1) = aerosolssw(idxday(1:nDay),:,sw_gas_props%get_nband(), 3) - sw_optical_props_aerosol%g(:,:,2:sw_gas_props%get_nband()-1) = aerosolssw(idxday(1:nDay),:,1:sw_gas_props%get_nband()-1,3) - endif - end subroutine GFS_rrtmgp_aerosol_optics_run + end subroutine rrtmgp_lw_aerosol_optics_run ! ######################################################################################### - ! SUBROUTINE GFS_rrtmgp_aerosol_optics_finalize() + ! SUBROUTINE rrtmgp_lw_aerosol_optics_finalize() ! ######################################################################################### - subroutine GFS_rrtmgp_aerosol_optics_finalize() - end subroutine GFS_rrtmgp_aerosol_optics_finalize -end module GFS_rrtmgp_aerosol_optics + subroutine rrtmgp_lw_aerosol_optics_finalize() + end subroutine rrtmgp_lw_aerosol_optics_finalize +end module rrtmgp_lw_aerosol_optics diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta new file mode 100644 index 000000000..ad68fd546 --- /dev/null +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -0,0 +1,173 @@ +[ccpp-table-properties] + name = rrtmgp_lw_aerosol_optics + type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 + +######################################################################## +[ccpp-arg-table] + name = rrtmgp_lw_aerosol_optics_run + type = scheme +[doLWrad] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nLev] + standard_name = vertical_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in + optional = F +[nTracer] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[nTracerAer] + standard_name = number_of_aerosol_tracers_MG + long_name = number of aerosol tracers for Morrison Gettelman MP + units = count + dimensions = () + type = integer + intent = in + optional = F +[p_lev] + standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa + long_name = air pressure at vertical interface for radiation calculation + units = hPa + dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[p_lay] + standard_name = air_pressure_at_layer_for_RRTMGP_in_hPa + long_name = air pressure at vertical layer for radiation calculation + units = hPa + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[p_lk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tv_lay] + standard_name = virtual_temperature + long_name = layer virtual temperature + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[relhum] + standard_name = relative_humidity + long_name = layer relative humidity + units = frac + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[lsmask] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[tracer] + standard_name = chemical_tracers + long_name = chemical tracers + units = g g-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[aerfld] + standard_name = aerosol_number_concentration_from_gocart_aerosol_climatology + long_name = GOCART aerosol climatology number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = in + optional = F +[lon] + standard_name = longitude + long_name = longitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[lat] + standard_name = latitude + long_name = latitude + units = radian + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[aerodp] + standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles + long_name = vertical integrated optical depth for various aerosol species + units = none + dimensions = (horizontal_loop_extent,number_of_species_for_aerosol_optical_depth) + type = real + kind = kind_phys + intent = inout + optional = F +[lw_optical_props_aerosol] + standard_name = longwave_optical_properties_for_aerosols + long_name = Fortran DDT containing RRTMGP optical properties + units = DDT + dimensions = () + type = ty_optical_props_1scl + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/rrtmgp_sw_aerosol_optics.F90 b/physics/rrtmgp_sw_aerosol_optics.F90 new file mode 100644 index 000000000..3a74771b7 --- /dev/null +++ b/physics/rrtmgp_sw_aerosol_optics.F90 @@ -0,0 +1,119 @@ +module rrtmgp_sw_aerosol_optics + use machine, only: kind_phys + use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp + use mo_optical_props, only: ty_optical_props_2str + use radiation_tools, only: check_error_msg + use rrtmgp_sw_gas_optics, only: sw_gas_props + use rrtmgp_lw_gas_optics, only: lw_gas_props + use module_radiation_aerosols, only: & + NF_AESW, & ! Number of optical-fields in SW output (3=tau+g+omega) + NF_AELW, & ! Number of optical-fields in LW output (3=tau+g+omega) + setaer, & ! Routine to compute aerosol radiative properties (tau,g,omega) + NSPC1 ! Number of species for vertically integrated aerosol optical-depth + use netcdf + + implicit none + + public rrtmgp_sw_aerosol_optics_init, rrtmgp_sw_aerosol_optics_run, rrtmgp_sw_aerosol_optics_finalize + +contains + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_aerosol_optics_init() + ! ######################################################################################### + subroutine rrtmgp_sw_aerosol_optics_init() + end subroutine rrtmgp_sw_aerosol_optics_init + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_aerosol_optics_run() + ! ######################################################################################### +!! \section arg_table_rrtmgp_sw_aerosol_optics_run +!! \htmlinclude rrtmgp_sw_aerosol_optics_run.html +!! + subroutine rrtmgp_sw_aerosol_optics_run(doSWrad, nCol, nLev, nTracer, nTracerAer, nDay, & + idxday, p_lev, p_lay, p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, & + aerodp, sw_optical_props_aerosol, errmsg, errflg ) + + ! Inputs + logical, intent(in) :: & + doSWrad ! Logical flag for shortwave radiation call + integer, intent(in) :: & + nCol, & ! Number of horizontal grid points + nDay, & ! Number of daylit points + nLev, & ! Number of vertical layers + nTracer, & ! Number of tracers + nTracerAer ! Number of aerosol tracers + integer,intent(in),dimension(:) :: & + idxday ! Indices for daylit points. + real(kind_phys), dimension(:), intent(in) :: & + lon, & ! Longitude + lat, & ! Latitude + lsmask ! Land/sea/sea-ice mask + real(kind_phys), dimension(:,:),intent(in) :: & + p_lay, & ! Pressure @ layer-centers (Pa) + tv_lay, & ! Virtual-temperature @ layer-centers (K) + relhum, & ! Relative-humidity @ layer-centers + p_lk ! Exner function @ layer-centers (1) + real(kind_phys), dimension(:, :,:),intent(in) :: & + tracer ! trace gas concentrations + real(kind_phys), dimension(:, :,:),intent(in) :: & + aerfld ! aerosol input concentrations + real(kind_phys), dimension(:,:),intent(in) :: & + p_lev ! Pressure @ layer-interfaces (Pa) + + ! Outputs + real(kind_phys), dimension(:,:), intent(inout) :: & + aerodp ! Vertical integrated optical depth for various aerosol species + type(ty_optical_props_2str),intent(out) :: & + sw_optical_props_aerosol ! RRTMGP DDT: Longwave aerosol optical properties (tau) + integer, intent(out) :: & + errflg ! CCPP error flag + character(len=*), intent(out) :: & + errmsg ! CCPP error message + + ! Local variables + real(kind_phys), dimension(nCol, nLev, lw_gas_props%get_nband(), NF_AELW) :: & + aerosolslw ! + real(kind_phys), dimension(nCol, nLev, sw_gas_props%get_nband(), NF_AESW) :: & + aerosolssw, aerosolssw2 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. doSWrad) return + if (nDay .gt. 0) then + + ! Call module_radiation_aerosols::setaer(),to setup aerosols property profile + call setaer(p_lev/100., p_lay/100., p_lk, tv_lay, relhum, lsmask, tracer, aerfld, lon, lat, nCol, nLev, & + nLev+1, .true., .true., aerosolssw2, aerosolslw, aerodp) + + ! Store aerosol optical properties + ! SW. + ! For RRTMGP SW the bands are now ordered from [IR(band) -> nIR -> UV], in RRTMG the + ! band ordering was [nIR -> UV -> IR(band)] + aerosolssw(1:nCol,:,1,1) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),1) + aerosolssw(1:nCol,:,1,2) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),2) + aerosolssw(1:nCol,:,1,3) = aerosolssw2(1:nCol,:,sw_gas_props%get_nband(),3) + aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),1) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,1) + aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),2) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,2) + aerosolssw(1:nCol,:,2:sw_gas_props%get_nband(),3) = aerosolssw2(1:nCol,:,1:sw_gas_props%get_nband()-1,3) + + ! Allocate RRTMGP DDT: Aerosol optics [nCol,nlev,nBands] + call check_error_msg('rrtmgp_sw_aerosol_optics_run',sw_optical_props_aerosol%alloc_2str( & + nDay, nlev, sw_gas_props%get_band_lims_wavenumber())) + + ! Copy aerosol optical information to RRTMGP DDT + sw_optical_props_aerosol%tau = aerosolssw(idxday(1:nday),:,:,1) + sw_optical_props_aerosol%ssa = aerosolssw(idxday(1:nday),:,:,2) + sw_optical_props_aerosol%g = aerosolssw(idxday(1:nday),:,:,3) + endif + + end subroutine rrtmgp_sw_aerosol_optics_run + + ! ######################################################################################### + ! SUBROUTINE rrtmgp_sw_aerosol_optics_finalize() + ! ######################################################################################### + subroutine rrtmgp_sw_aerosol_optics_finalize() + end subroutine rrtmgp_sw_aerosol_optics_finalize +end module rrtmgp_sw_aerosol_optics diff --git a/physics/GFS_rrtmgp_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta similarity index 91% rename from physics/GFS_rrtmgp_aerosol_optics.meta rename to physics/rrtmgp_sw_aerosol_optics.meta index aa7f6d4a5..f4909c794 100644 --- a/physics/GFS_rrtmgp_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -1,15 +1,15 @@ [ccpp-table-properties] - name = GFS_rrtmgp_aerosol_optics + name = rrtmgp_sw_aerosol_optics type = scheme dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radiation_tools.F90 ######################################################################## [ccpp-arg-table] - name = GFS_rrtmgp_aerosol_optics_run + name = rrtmgp_sw_aerosol_optics_run type = scheme -[doLWrad] - standard_name = flag_to_calc_lw - long_name = logical flags for lw radiation calls +[doSWrad] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls units = flag dimensions = () type = logical @@ -23,22 +23,6 @@ type = integer intent = in optional = F -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[idxday] - standard_name = daytime_points - long_name = daytime points - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F [nLev] standard_name = vertical_dimension long_name = number of vertical levels @@ -63,6 +47,22 @@ type = integer intent = in optional = F +[nday] + standard_name = daytime_points_dimension + long_name = daytime points dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[idxday] + standard_name = daytime_points + long_name = daytime points + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure at vertical interface for radiation calculation @@ -162,14 +162,6 @@ kind = kind_phys intent = inout optional = F -[lw_optical_props_aerosol] - standard_name = longwave_optical_properties_for_aerosols - long_name = Fortran DDT containing RRTMGP optical properties - units = DDT - dimensions = () - type = ty_optical_props_1scl - intent = inout - optional = F [sw_optical_props_aerosol] standard_name = shortwave_optical_properties_for_aerosols long_name = Fortran DDT containing RRTMGP optical properties From 36b6487983d45ac68b6401c4401a02214c369b16 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Tue, 25 May 2021 17:54:48 +0000 Subject: [PATCH 100/165] fix bug by adding a comma and add condensation/evap --- physics/module_mp_thompson.F90 | 33 ++++++++++++++++++++++++++------- physics/mp_thompson.F90 | 17 ++++++++++++----- 2 files changed, 38 insertions(+), 12 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index af09ab58f..5f2125557 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1018,7 +1018,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims - errmsg, errflg, reset, vts1) + errmsg, errflg, reset, vts1, prw_vcdc, & + prw_vcde) implicit none @@ -1028,7 +1029,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & its,ite, jts,jte, kts,kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & qv, qc, qr, qi, qs, qg, ni, nr - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: vts1 + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & + vts1,prw_vcdc,prw_vcde REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & tt, th @@ -1069,7 +1071,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ - REAL, DIMENSION(kts:kte):: vtsk1 + REAL, DIMENSION(kts:kte):: vtsk1,prw_vcdc1,prw_vcde1 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) @@ -1266,6 +1268,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) vtsk1(k) = 0. vts1(i,k,j) = 0. + prw_vcdc1(k) = 0. + prw_vcdc(i,k,j) = 0. + prw_vcde1(k) = 0. + prw_vcde(i,k,j) = 0. enddo if (is_aerosol_aware) then do k = kts, kte @@ -1289,7 +1295,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j, vtsk1) + kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1343,7 +1349,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg(i,k,j) = qg1d(k) ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) - vts1(i,k,j) = vtsk1(k) + vts1(i,k,j) = vtsk1(k) + prw_vcdc(i,k,j) = prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde1(k) + if (present(tt)) then; tt(i,k,j) = t1d(k) else @@ -1557,7 +1566,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rainprod, evapprod, & #endif rand1, rand2, rand3, & - kts, kte, dt, ii, jj, vtsk1) + kts, kte, dt, ii, jj, vtsk1, prw_vcdc1, prw_vcde1) #ifdef MPI use mpi #endif @@ -1572,7 +1581,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 - REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1 + REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1,prw_vcdc1,prw_vcde1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & @@ -3371,6 +3380,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtck(k) = 0. vtnck(k) = 0. vtsk1(k) = 0. + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. enddo if (ANY(L_qr .eqv. .true.)) then @@ -3790,6 +3801,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qg1d(k) = qg1d(k) + qgten(k)*DT if (qg1d(k) .le. R1) qg1d(k) = 0.0 enddo +! Diagnostics + do k = kts, kte + if(prw_vcd(k).gt.0)then + prw_vcdc1(k) = prw_vcd(k)*dt + elseif(prw_vcd(k).lt.0)then + prw_vcde1(k) = -1*prw_vcd(k)*dt + endif + enddo end subroutine mp_thompson !>@} diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index ab9f49049..4444abca7 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -432,7 +432,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & its,ite, jts,jte, kts,kte !Auxillary fields - real(kind_phys) :: vts1(1:ncol,1:nlev) + real(kind_phys) :: vts1(1:ncol,1:nlev),prw_vcdc(1:ncol,1:nlev),prw_vcde(1:ncol,1:nlev) ! Initialize the CCPP error handling variables errmsg = '' @@ -572,7 +572,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & + prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -591,7 +592,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & + prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) end if else if (do_effective_radii) then @@ -612,7 +614,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & + prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -630,7 +633,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & + prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) end if end if if (errflg/=0) return @@ -661,7 +665,10 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ice = ice + max(0.0, delta_ice_mp/1000.0_kind_phys) snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) +!Diagnostics aux3d(:,:,1) = vts1 + aux3d(:,:,2) = aux3d(:,:,2) + prw_vcdc + aux3d(:,:,3) = aux3d(:,:,3) + prw_vcde end subroutine mp_thompson_run !>@} From eb7837d7f32e83fb6a151dbae50172bda5fd83db Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Tue, 25 May 2021 20:05:16 +0000 Subject: [PATCH 101/165] Bug fix. Add transition to HR adjustment. --- physics/dcyc2.f | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 09c80a97e..8e2f86e5a 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -424,7 +424,8 @@ subroutine dcyc2t3_run & else lfnc = 1. endif - dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k)*lfnc + dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + & + & htrlw(i,k)*lfnc + (1.-lfnc)*hlw(i,k) enddo enddo else From c55797d86461beed73dc75c6ce8cd480ffe22263 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 25 May 2021 15:57:36 -0600 Subject: [PATCH 102/165] Optimize use of auxiliary arrays --- physics/module_mp_thompson.F90 | 7 ++----- physics/mp_thompson.F90 | 24 +++++++++--------------- 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 5f2125557..c0e40971a 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1267,11 +1267,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) vtsk1(k) = 0. - vts1(i,k,j) = 0. prw_vcdc1(k) = 0. - prw_vcdc(i,k,j) = 0. prw_vcde1(k) = 0. - prw_vcde(i,k,j) = 0. enddo if (is_aerosol_aware) then do k = kts, kte @@ -1350,8 +1347,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) vts1(i,k,j) = vtsk1(k) - prw_vcdc(i,k,j) = prw_vcdc1(k) - prw_vcde(i,k,j) = prw_vcde1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) if (present(tt)) then; tt(i,k,j) = t1d(k) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 4444abca7..daa492aa9 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -431,9 +431,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - !Auxillary fields - real(kind_phys) :: vts1(1:ncol,1:nlev),prw_vcdc(1:ncol,1:nlev),prw_vcde(1:ncol,1:nlev) - ! Initialize the CCPP error handling variables errmsg = '' errflg = 0 @@ -572,8 +569,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & - prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -592,8 +589,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & - prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) end if else if (do_effective_radii) then @@ -614,8 +611,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & - prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -633,8 +630,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset, vts1=vts1, & - prw_vcdc=prw_vcdc, prw_vcde=prw_vcde) + errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) end if end if if (errflg/=0) return @@ -665,10 +662,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ice = ice + max(0.0, delta_ice_mp/1000.0_kind_phys) snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) -!Diagnostics - aux3d(:,:,1) = vts1 - aux3d(:,:,2) = aux3d(:,:,2) + prw_vcdc - aux3d(:,:,3) = aux3d(:,:,3) + prw_vcde + end subroutine mp_thompson_run !>@} From f2d55708f4f8d1162284145707e0c53a2677e8f8 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 26 May 2021 10:33:24 +0000 Subject: [PATCH 103/165] Removed exp(1) from scaling --- physics/dcyc2.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 8e2f86e5a..796c36f12 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -420,7 +420,7 @@ subroutine dcyc2t3_run & ! using a logistic function if (damp_LW_fluxadj) then dp = p_lev(i,k) - lfnc_p0 - lfnc = L / (1+exp(-lfnc_k_grad*exp(1.)*dp/lfnc_p0)) + lfnc = L / (1+exp(-lfnc_k_grad*dp/lfnc_p0)) else lfnc = 1. endif From ea0113929c9ec254e15275ab55f094360d0ffb55 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 26 May 2021 11:18:19 +0000 Subject: [PATCH 104/165] Housekeeping. Added comments. --- physics/dcyc2.f | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 796c36f12..cfe7c75a8 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -260,14 +260,14 @@ subroutine dcyc2t3_run & & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 - real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,c1,c2,c3,c4,c5, & - & dP,lfnc + real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,dT_sfc, & + &fluxlwDOWN_jac,dP,lfnc,c1 ! Length scale for flux-adjustment scaling real(kind=kind_phys), parameter :: & & L = 1. ! Scaling factor for downwelling LW Jacobian profile. real(kind=kind_phys), parameter :: & - & c0 = 0.2 + & gamma = 0.2 ! !===> ... begin here ! @@ -400,19 +400,21 @@ subroutine dcyc2t3_run & ! L = 1, fix scale between 0-1. ! k (steepness) and p0 (midpoint) are controlled via namelist do i = 1, im - c1 = fluxlwUP_jac(i,iSFC) - c2 = fluxlwUP_jac(i,iTOA) / c1 - c3 = t_lev2(i,iSFC) - t_lev(i,iSFC) + c1 = fluxlwUP_jac(i,iTOA) / fluxlwUP_jac(i,iSFC) + dT_sfc = t_lev2(i,iSFC) - t_lev(i,iSFC) do k = 1, levs - ! Only apply the Jacobian adjustment below plim_fluxAdj_upper - c4 = fluxlwUP_jac(i,k)/c1 - fluxlwnet = (flux2D_lwUP(i,k+1) - flux2D_lwUP(i,k) - & - & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) - ! (Eq. 9) - c5 = c0 * (c4 - c2) / (1 - c2) - ! (Eq. 10) - fluxlwnet_adj = fluxlwnet + c3*(c4-c5) - ! Compute adjusted heating rate + ! LW net flux + fluxlwnet = (flux2D_lwUP(i, k+1) - flux2D_lwUP(i, k) - & + & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) + ! Downward LW Jacobian (Eq. 9) + fluxlwDOWN_jac = gamma * & + & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - c1) / & + & (1 - c1) + ! Adjusted LW net flux(Eq. 10) + fluxlwnet_adj = fluxlwnet + dT_sfc* & + & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - & + & fluxlwDOWN_jac) + ! Adjusted LW heating rate htrlw(i,k) = fluxlwnet_adj * con_g / & & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) @@ -420,7 +422,7 @@ subroutine dcyc2t3_run & ! using a logistic function if (damp_LW_fluxadj) then dp = p_lev(i,k) - lfnc_p0 - lfnc = L / (1+exp(-lfnc_k_grad*dp/lfnc_p0)) + lfnc = L / (1+exp(-(lfnc_k_grad/lfnc_p0)*dp)) else lfnc = 1. endif From d93adbeb519a58e0aedbbe92a840186ee312cb54 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 26 May 2021 22:00:59 +0000 Subject: [PATCH 105/165] Further cleanup of dcyc2 --- physics/dcyc2.f | 14 +++++++------- physics/dcyc2.meta | 12 ++++++------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index cfe7c75a8..8700e2bfb 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -179,7 +179,7 @@ subroutine dcyc2t3_run & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & & dry, icy, wet, minGPtemp, maxGPtemp, damp_LW_fluxadj, & - & lfnc_k_grad, lfnc_p0, minGPpres, use_LW_jacobian, sfculw, & + & lfnc_k, lfnc_p0, minGPpres, use_LW_jacobian, sfculw, & & fluxlwUP_jac, t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, & & flux2D_lwDOWN, pert_radtend, do_sppt,ca_global, & ! & dry, icy, wet, lprnt, ipr, & @@ -217,7 +217,7 @@ subroutine dcyc2t3_run & & pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres, minGPtemp, maxGPtemp, lfnc_k_grad, & + & deltim, fhswr, minGPpres, minGPtemp, maxGPtemp, lfnc_k, & & lfnc_p0 real(kind=kind_phys), dimension(:), intent(in) :: & @@ -261,7 +261,7 @@ subroutine dcyc2t3_run & real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,dT_sfc, & - &fluxlwDOWN_jac,dP,lfnc,c1 + &fluxlwDOWN_jac,lfnc,c1 ! Length scale for flux-adjustment scaling real(kind=kind_phys), parameter :: & & L = 1. @@ -397,8 +397,9 @@ subroutine dcyc2t3_run & ! ! Optionally, the flux adjustment can be damped with height using a logistic function ! fx ~ L / (1 + exp(-k*dp)), where dp = p - p0 - ! L = 1, fix scale between 0-1. - ! k (steepness) and p0 (midpoint) are controlled via namelist + ! L = 1, fix scale between 0-1. - Fixed + ! k = 1 / pressure decay length (Pa) - Controlled by namelist + ! p0 = Transition pressure (Pa) - Controlled by namelsit do i = 1, im c1 = fluxlwUP_jac(i,iTOA) / fluxlwUP_jac(i,iSFC) dT_sfc = t_lev2(i,iSFC) - t_lev(i,iSFC) @@ -421,8 +422,7 @@ subroutine dcyc2t3_run & ! Add radiative heating rates to physics heating rate. Optionally, scaled w/ height ! using a logistic function if (damp_LW_fluxadj) then - dp = p_lev(i,k) - lfnc_p0 - lfnc = L / (1+exp(-(lfnc_k_grad/lfnc_p0)*dp)) + lfnc = L / (1+exp(-lfnc_k*(p_lev(i,k) - lfnc_p0))) else lfnc = 1. endif diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index dceb9ce77..5ba718c2e 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -396,18 +396,18 @@ type = logical intent = in optional = F -[lfnc_k_grad] - standard_name = steepness_of_flux_damping - long_name = steepness of logistic function for damping the LW flux adjustment - units = none +[lfnc_k] + standard_name = transition_pressure_length_scale_for_flux_damping + long_name = depth of transition layer in logistic function for LW flux adjustment damping + units = Pa dimensions = () type = real kind = kind_phys intent = in optional = F [lfnc_p0] - standard_name = midpoint_used_for_flux_damping - long_name = midpoint for damping the LW flux adjustment + standard_name = transition_pressure_for_flux_damping + long_name = transition pressure for LW flux adjustment damping units = Pa dimensions = () type = real From fe44d62031c77b4232f331ce27661aef7847fe96 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Wed, 26 May 2021 22:04:26 +0000 Subject: [PATCH 106/165] Revert "Added more safeguards against out-of-bounds temperature to GP inputs." This reverts commit 6961b10546035b55021132e62ce139333eed9cc0. --- physics/GFS_rrtmgp_pre.F90 | 12 ++++-------- physics/GFS_rrtmgp_pre.meta | 9 --------- physics/dcyc2.f | 15 +++++++-------- physics/dcyc2.meta | 18 ------------------ physics/radiation_tools.F90 | 20 ++++++-------------- physics/rrtmgp_lw_gas_optics.F90 | 4 +--- physics/rrtmgp_lw_gas_optics.meta | 9 --------- 7 files changed, 18 insertions(+), 69 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.F90 b/physics/GFS_rrtmgp_pre.F90 index af7e5f1a0..88e534595 100644 --- a/physics/GFS_rrtmgp_pre.F90 +++ b/physics/GFS_rrtmgp_pre.F90 @@ -98,8 +98,8 @@ end subroutine GFS_rrtmgp_pre_init !! subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, fhlwr, & xlat, xlon, prsl, tgrs, prslk, prsi, qgrs, tsfc, con_eps, con_epsm1, con_fvirt, & - con_epsqs, minGPpres, minGPtemp, maxGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, & - tsfa, qs_lay, q_lay, tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) + con_epsqs, minGPpres, minGPtemp, raddt, p_lay, t_lay, p_lev, t_lev, tsfg, tsfa, & + qs_lay, q_lay, tv_lay, relhum, tracer, gas_concentrations, errmsg, errflg) ! Inputs integer, intent(in) :: & @@ -112,7 +112,6 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f lslwr ! Call LW radiation real(kind_phys), intent(in) :: & minGPtemp, & ! Minimum temperature allowed in RRTMGP. - maxGPtemp, & ! Maximum temperature allowed in RRTMGP. minGPpres, & ! Minimum pressure allowed in RRTMGP. fhswr, & ! Frequency of SW radiation call. fhlwr ! Frequency of LW radiation call. @@ -209,14 +208,11 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f if (t_lay(iCol,iLay) .le. minGPtemp) then t_lay(iCol,iLay) = minGPtemp + epsilon(minGPtemp) endif - if (t_lay(iCol,iLay) .ge. maxGPtemp) then - t_lay(iCol,iLay) = maxGPtemp - epsilon(maxGPtemp) - endif enddo enddo ! Temperature at layer-interfaces - call cmp_tlev(nCol,nLev,minGPpres,minGPtemp,maxGPtemp,p_lay,t_lay,p_lev,tsfc,t_lev) + call cmp_tlev(nCol,nLev,minGPpres,p_lay,t_lay,p_lev,tsfc,t_lev) ! Compute a bunch of thermodynamic fields needed by the cloud microphysics schemes. ! Relative humidity, saturation mixing-ratio, vapor mixing-ratio, virtual temperature, @@ -277,7 +273,7 @@ subroutine GFS_rrtmgp_pre_run(nCol, nLev, nTracers, i_o3, lsswr, lslwr, fhswr, f ! ####################################################################################### ! Setup surface ground temperature and ground/air skin temperature if required. ! ####################################################################################### - tsfg(1:NCOL) = t_lev(1:NCOL,iSFC) + tsfg(1:NCOL) = tsfc(1:NCOL) tsfa(1:NCOL) = t_lay(1:NCOL,iSFC) end subroutine GFS_rrtmgp_pre_run diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 895bbc630..8096aef2a 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -239,15 +239,6 @@ kind = kind_phys intent = in optional = F -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [raddt] standard_name = time_step_for_radiation long_name = radiation time step diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 8700e2bfb..6247f360f 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -178,10 +178,10 @@ subroutine dcyc2t3_run & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & - & dry, icy, wet, minGPtemp, maxGPtemp, damp_LW_fluxadj, & - & lfnc_k, lfnc_p0, minGPpres, use_LW_jacobian, sfculw, & - & fluxlwUP_jac, t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, & - & flux2D_lwDOWN, pert_radtend, do_sppt,ca_global, & + & dry, icy, wet, damp_LW_fluxadj, lfnc_k, lfnc_p0, & + & minGPpres, use_LW_jacobian, sfculw, fluxlwUP_jac, & + & t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, flux2D_lwDOWN, & + & pert_radtend, do_sppt,ca_global, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: & dtdt,dtdtnp,htrlw, & @@ -217,8 +217,7 @@ subroutine dcyc2t3_run & & pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres, minGPtemp, maxGPtemp, lfnc_k, & - & lfnc_p0 + & deltim, fhswr, minGPpres, minGPtemp, lfnc_k, lfnc_p0 real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & @@ -384,8 +383,8 @@ subroutine dcyc2t3_run & ! ! Compute temperatute at level interfaces. ! - call cmp_tlev(im, levs, minGPpres, minGPtemp, maxGPtemp, p_lay,& - & t_lay, p_lev, tsfc, t_lev2) + call cmp_tlev(im, levs, minGPpres, p_lay, t_lay, p_lev, tsfc, & + & t_lev2) ! Compute adjusted net LW flux foillowing Hogan and Bozzo 2015 (10.1002/2015MS000455) ! Here we assume that the profile of the downwelling LW Jaconiam has the same shape diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index 5ba718c2e..91e01a2d2 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -353,24 +353,6 @@ type = logical intent = in optional = F -[minGPtemp] - standard_name = minimum_temperature_in_RRTMGP - long_name = minimum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [minGPpres] standard_name = minimum_pressure_in_RRTMGP long_name = minimum pressure allowed in RRTMGP diff --git a/physics/radiation_tools.F90 b/physics/radiation_tools.F90 index a8d3f5457..c6524aab6 100644 --- a/physics/radiation_tools.F90 +++ b/physics/radiation_tools.F90 @@ -2,16 +2,20 @@ module radiation_tools use machine, only: & kind_phys ! Working type implicit none + + real(kind_phys) :: & + rrtmgp_minP, & ! Minimum pressure allowed in RRTMGP + rrtmgp_minT ! Minimum temperature allowed in RRTMGP contains ! ######################################################################################### ! ######################################################################################### - subroutine cmp_tlev(nCol,nLev,minP,minT,maxT,p_lay,t_lay,p_lev,tsfc,t_lev) + subroutine cmp_tlev(nCol,nLev,minP,p_lay,t_lay,p_lev,tsfc,t_lev) ! Inputs integer, intent(in) :: & nCol,nLev real(kind_phys),intent(in) :: & - minP,minT,maxT + minP real(kind_phys),dimension(nCol),intent(in) :: & tsfc real(kind_phys),dimension(nCol,nLev),intent(in) :: & @@ -74,18 +78,6 @@ subroutine cmp_tlev(nCol,nLev,minP,minT,maxT,p_lay,t_lay,p_lev,tsfc,t_lev) t_lev(1:NCOL,iTOA+1) = t_lay(1:NCOL,iTOA) endif - ! Bound temperature at layer interfaces - do iCol=1,NCOL - do iLay=1,nLev+1 - if (t_lev(iCol,iLay) .le. minT) then - t_lev(iCol,iLay) = minT + epsilon(minT) - endif - if (t_lev(iCol,iLay) .ge. maxT) then - t_lev(iCol,iLay) = maxT - epsilon(maxT) - endif - enddo - enddo - end subroutine cmp_tlev ! ######################################################################################### diff --git a/physics/rrtmgp_lw_gas_optics.F90 b/physics/rrtmgp_lw_gas_optics.F90 index d7201e026..a116ad772 100644 --- a/physics/rrtmgp_lw_gas_optics.F90 +++ b/physics/rrtmgp_lw_gas_optics.F90 @@ -76,7 +76,7 @@ module rrtmgp_lw_gas_optics !! \htmlinclude rrtmgp_lw_gas_optics_init.html !! subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicomm, & - mpirank, mpiroot, gas_concentrations, minGPpres, minGPtemp, maxGPtemp, errmsg, errflg) + mpirank, mpiroot, gas_concentrations, minGPpres, minGPtemp, errmsg, errflg) ! Inputs type(ty_gas_concs), intent(inout) :: & @@ -96,7 +96,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom errflg ! CCPP error code real(kind_phys), intent(out) :: & minGPtemp, & ! Minimum temperature allowed by RRTMGP. - maxGPtemp, & ! Maximum temperature allowed by RRTMG. minGPpres ! Minimum pressure allowed by RRTMGP. ! Local variables @@ -451,7 +450,6 @@ subroutine rrtmgp_lw_gas_optics_init(rrtmgp_root_dir, rrtmgp_lw_file_gas, mpicom ! temperature (GFS_rrtmgp_pre.F90) minGPpres = lw_gas_props%get_press_min() minGPtemp = lw_gas_props%get_temp_min() - maxGPtemp = lw_gas_props%get_temp_max() end subroutine rrtmgp_lw_gas_optics_init diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 823501cfa..c92567e14 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -92,15 +92,6 @@ kind = kind_phys intent = out optional = F -[maxGPtemp] - standard_name = maximum_temperature_in_RRTMGP - long_name = maximum temperature allowed in RRTMGP - units = K - dimensions = () - type = real - kind = kind_phys - intent = out - optional = F ######################################################################## [ccpp-arg-table] From d642ecfa40b4c539339bcc8b3e001fc69059d1ff Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 May 2021 20:01:46 -0400 Subject: [PATCH 107/165] fixing a bug in surface cycling and updating for fractional grid --- physics/gcycle.F90 | 120 +++++++++++++++++++++++++++------------------ physics/sfcsub.F | 26 ++++++---- 2 files changed, 90 insertions(+), 56 deletions(-) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 9bba1546a..4a60337ec 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,26 +15,26 @@ module gcycle_mod !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & xlat_d, xlon_d, slmsk, imap, jmap) ! ! use machine, only: kind_phys, kind_io8 implicit none - integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & + integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & tile_num, nlunit, lsoil, lsoil_lsm, kice integer, intent(in) :: idate(:), ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:),& - min_seaice, min_lakeice, & + real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & + min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind=kind_phys), intent(inout) :: smc(:,:), & slc(:,:), & @@ -80,7 +80,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, ! ! Local variables ! --------------- - real(kind=kind_phys) :: & +! real(kind=kind_phys) :: & + real(kind=kind_io8) :: & slmskl (nx*ny), & slmskw (nx*ny), & TSFFCS (nx*ny), & @@ -94,8 +95,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, real (kind=kind_io8) :: min_ice(nx*ny) + integer :: i_indx(nx*ny), j_indx(nx*ny) character(len=6) :: tile_num_ch - real(kind=kind_phys) :: sig1t, dt_warm + real(kind=kind_phys) :: sig1t integer :: npts, nb, ix, jx, ls, ios, ll logical :: exists ! @@ -118,13 +120,52 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, TSFFCS = tref else TSFFCS = tsfco - endif + end if ! + if (frac_grid) then + do ix=1,npts + if (landfrac(ix) > -1.0e-8_kind_phys) then + slmskl(ix) = ceiling(landfrac(ix)-1.0e-8_kind_phys) + slmskw(ix) = floor(landfrac(ix)+1.0e-8_kind_phys) +! slmskw(ix) = slmskl(ix) + else + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + endif + ZORFCS(ix) = zorll(ix) + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + else + ZORFCS(ix) = zorlo(ix) + endif + endif + enddo + else + do ix=1,npts + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + ZORFCS(ix) = zorll(ix) + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + ZORFCS(ix) = zorlo(ix) + endif + enddo + endif do ix=1,npts - if (landfrac(ix) > -1.0e-6_kind_phys) then - slmskl(ix) = ceiling(landfrac(ix)-1.0e-6_kind_phys) - slmskw(ix) = floor(landfrac(ix)+1.0e-6_kind_phys) - endif + i_indx(ix) = imap(ix) + isc - 1 + j_indx(ix) = jmap(ix) + jsc - 1 if (lakefrac(ix) > 0.0_kind_phys) then min_ice(ix) = min_lakeice @@ -132,29 +173,20 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, min_ice(ix) = min_seaice endif - zorfcs(ix) = zorll (ix) - if (nint(slmskl(ix)) /= 1 ) then - if (fice(ix) >= min_ice(ix)) then - zorfcs(ix) = zorli(ix) - else - zorfcs(ix) = zorlo(ix) - endif - endif - - IF (fice(ix) >= min_ice(ix)) THEN + IF (slmsk(ix) > 1.99_kind_phys) THEN AISFCS(ix) = 1.0_kind_phys ELSE AISFCS(ix) = 0.0_kind_phys ENDIF -! + ! ALFFC1(ix ) = facsf(ix) ALFFC1(ix + npts ) = facwf(ix) -! + ! ALBFC1(ix ) = alvsf(ix) ALBFC1(ix + npts ) = alvwf(ix) ALBFC1(ix + npts*2) = alnsf(ix) ALBFC1(ix + npts*3) = alnwf(ix) -! + ! do ls = 1,max(lsoil,lsoil_lsm) ll = ix + (ls-1)*npts if (lsoil == lsoil_lsm) then @@ -167,6 +199,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, SLCFC1(ll) = sh2o(ix,ls) endif enddo +! enddo ! #ifndef INTERNAL_FILE_NML @@ -191,7 +224,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & min_ice, ialb, isot, ivegsrc, & - trim(tile_num_ch), imap, jmap) + trim(tile_num_ch), i_indx, j_indx) #ifndef INTERNAL_FILE_NML close (Model%nlunit) #endif @@ -199,35 +232,28 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, if ( nsst > 0 ) then tref = TSFFCS else + tsfc = TSFFCS tsfco = TSFFCS endif ! do ix=1,npts zorll(ix) = ZORFCS(ix) - if (.not. frac_grid) then - if (slmsk(ix) > 1.9_kind_phys) then + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then zorli(ix) = ZORFCS(ix) elseif (slmsk(ix) < 0.1_kind_phys) then zorlo(ix) = ZORFCS(ix) endif - else - if (nint(slmskw(ix)) == 0 .and. nint(slmskl(ix)) /= 1) then - if (fice(ix) >= min_ice(ix)) then - zorli(ix) = ZORFCS(ix) - else - zorlo(ix) = ZORFCS(ix) - endif - endif endif -! + ! facsf(ix) = ALFFC1(ix ) facwf(ix) = ALFFC1(ix + npts ) -! + ! alvsf(ix) = ALBFC1(ix ) alvwf(ix) = ALBFC1(ix + npts ) alnsf(ix) = ALBFC1(ix + npts*2) alnwf(ix) = ALBFC1(ix + npts*3) -! + ! do ls = 1,max(lsoil,lsoil_lsm) ll = ix + (ls-1)*npts if(lsoil == lsoil_lsm) then @@ -236,10 +262,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, slc(ix,ls) = SLCFC1(ll) else smois(ix,ls) = SMCFC1(ll) - tslb(ix,ls) = STCFC1(ll) - sh2o(ix,ls) = SLCFC1(ll) + tslb(ix,ls) = STCFC1(ll) + sh2o(ix,ls) = SLCFC1(ll) endif -! if (ls <= kice) tiice(ix,ls) = STCFC1(ll) +! if (ls<=kice) tiice(ix,ls) = STCFC1(ll) enddo enddo ! diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 0a8ab10e6..002103e10 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -788,8 +788,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! 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) + 66.35) -! tem2 = abs(rlo(i) - 109.01) +! tem1 = abs(rla(i) - 60.11) +! tem2 = abs(rlo(i) - 5.38) ! if(tem1 < 0.10 .and. tem2 < 0.10) then ! lprnt = .true. ! iprnt = i @@ -1093,6 +1093,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & icefl1(i) = .true. enddo ! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) +! if(lprnt) print *,' slifcsin=',slifcs(iprnt) +! if(lprnt) print *,'slmskl=',slmskl(iprnt),' slmskw=',slmskw(iprnt) ! ! read climatology fields ! @@ -1198,7 +1200,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call setlsi(slmskw,aisclm,len,aicice,sliclm) ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmskw=',slmskw(iprnt) +! &,sliclm(iprnt),' slmskw=',slmskw(iprnt) ! ! write(6,*) 'sliclm' ! znnt=1. @@ -1542,8 +1544,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & aisanl(i) = acnanl(i) enddo endif -! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmskw=',slmskw(iprnt) +! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' & +! &,glacir(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) @@ -1552,8 +1554,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! call setlsi(slmskw,aisanl,len,aicice,slianl) -! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmskw=',slmskw(iprnt) +! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' & +! &,slianl(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! ! do k=1,lsoil @@ -2074,7 +2076,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) ! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) ! if(lprnt) print *,' stcan=',stcanl(iprnt,:) -! + ! set tsfc to tsnow over snow ! call snosfc(snoanl,tsfanl,tsfsmx,len,me) @@ -2504,9 +2506,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif enddo endif + do i=1,len + if (nint(slmskl(i)) == 1 .and. nint(slmskw(i)) == 0) then + slifcs(i) = slmskl(i) ! resetting slmsk to land value where land/wate/ice coexist + endif + enddo ! ! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) ! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:) +! if(lprnt) print *,' slifcsend=',slifcs(iprnt) return end subroutine sfccycle @@ -7411,7 +7419,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil,slmskl,slmskw, & if (me .eq. 0) write(6,*) 'climatological slope read in.' endif ! -! max snow albeod +! max snow albedo ! if(fnabsc(1:8).ne.' ') then if ( index(fnabsc, "tileX.nc") == 0) then ! grib file From 108a82f2b8aa0a896abd601d36c05d18c1b8b325 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Thu, 27 May 2021 12:29:41 +0000 Subject: [PATCH 108/165] Fix compilation failure --- physics/sfc_ocean.F | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 3f0fd23bc..79a9eb295 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -98,11 +98,12 @@ subroutine sfc_ocean_run & implicit none ! --- constant parameters: - real (kind=kind_phys), parameter :: one = 1.0_kind_phys, zero = 0.0_kind_phys & - &, qmin = 1.0e-8_kind_phys + real (kind=kind_phys), parameter :: one = 1.0_kind_phys, & + & zero = 0.0_kind_phys, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - real (kind=kind_phys), intent(in) :: hvap, cp, rd, eps, epsm1, rvrdm1 + real (kind=kind_phys), intent(in) :: hvap, cp, rd, & + & eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind From bc605882a92c47ff880688bc1f0dc3309531e408 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Thu, 27 May 2021 12:40:11 +0000 Subject: [PATCH 109/165] Fix line continuation --- physics/samfdeepcnv.f | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index a8905696c..edcf55d66 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -10,8 +10,7 @@ module samfdeepcnv contains - subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, -& + subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & & errmsg, errflg) integer, intent(in) :: imfdeepcnv @@ -22,8 +21,7 @@ subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, ! Consistency checks if (imfdeepcnv/=imfdeepcnv_samf) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', -& + write(errmsg,'(*(a))') 'Logic error: namelist choice of', & & ' deep convection is different from SAMF scheme' errflg = 1 return From 5a3c4e0dacb25cb3c1eee7048bee884bd2c4cc1e Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Thu, 27 May 2021 12:45:40 +0000 Subject: [PATCH 110/165] Fix line continuation problem --- physics/samfshalcnv.f | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index cfc7654f8..7fd60f5f8 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -9,8 +9,7 @@ module samfshalcnv contains - subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, -& + subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, & & errmsg, errflg) integer, intent(in) :: imfshalcnv @@ -22,8 +21,7 @@ subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, ! Consistency checks if (imfshalcnv/=imfshalcnv_samf) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', -& + write(errmsg,'(*(a))') 'Logic error: namelist choice of', & & ' shallow convection is different from SAMF' errflg = 1 return From 916a5cd8de49c953d529b4462ddc0c994e507ce5 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Thu, 27 May 2021 13:45:00 +0000 Subject: [PATCH 111/165] Updated TKE-EDMF --- physics/satmedmfvdifq.F | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index f6ab554ca..a59c43e53 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -179,6 +179,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & ucko(im,km), vcko(im,km), & buou(im,km), xmf(im,km) ! +! temporary local variables for instantaneous surface fluxes +! (they will be removed later) +! + real(kind=kind_phys) dusfc1(im),dvsfc1(im),dtsfc1(im),dqsfc1(im) +! ! variables for stratocumulus-top induced downdrafts ! real(kind=kind_phys) tcdo(im,km), qcdo(im,km,ntrac), @@ -379,11 +384,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !> - Some output variables and logical flags are initialized do i = 1,im z0(i) = 0.01 * zorl(i) - rho_a(i) = prsl(i,1) / (rd * t1(i,1)) - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. + rho_a(i) = prsl(i,1)/(rd*t1(i,1)*(1.+fv*max(q1(i,1,1),qmin))) + dusfc1(i) = 0. + dvsfc1(i) = 0. + dtsfc1(i) = 0. + dqsfc1(i) = 0. kpbl(i) = 1 hpbl(i) = 0. kpblx(i) = 1 @@ -1479,8 +1484,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend 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 + dtsfc1(i) = dtsfc1(i)+cont*del(i,k)*ttend + dqsfc1(i) = dqsfc1(i)+conq*del(i,k)*qtend enddo enddo do i = 1,im @@ -1618,8 +1623,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(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 + dusfc1(i) = dusfc1(i)+conw*del(i,k)*utend + dvsfc1(i) = dvsfc1(i)+conw*del(i,k)*vtend enddo enddo do i = 1,im From 6762adbcf2fafed1590624256e7410c225636e8c Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Thu, 27 May 2021 13:59:07 +0000 Subject: [PATCH 112/165] temperature tendency diagnostics added --- physics/module_mp_thompson.F90 | 147 ++++++++++++++++++++++++++++++--- 1 file changed, 136 insertions(+), 11 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index c0e40971a..b66bdc44a 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1019,7 +1019,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims errmsg, errflg, reset, vts1, prw_vcdc, & - prw_vcde) + prw_vcde, tpri_inu, tpri_ide, tprs_ide, & + tprs_sde, tprg_gde, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprs_scw, tprg_rcs, tprs_rcs, tprr_rci, & + tprg_rcg, tprw_vcd, tprr_sml, tprr_gml, & + tprr_rcg, tprr_rcs, tprv_rev, txri,txrc) implicit none @@ -1030,7 +1035,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & qv, qc, qr, qi, qs, qg, ni, nr REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - vts1,prw_vcdc,prw_vcde + vts1,prw_vcdc,prw_vcde, & + tpri_inu,tpri_ide,tprs_ide,tprs_sde,tprg_gde, & + tpri_iha,tpri_wfz,tpri_rfz,tprg_rfz,tprs_scw, & + tprg_scw,tprs_scw,tprg_rcs,tprs_rcs,tprr_rci, & + tprg_rcg,tprw_vcd,tprr_sml,tprr_gml,tprr_rcg, & + tprr_rcs,tprv_rev,txri,txrc REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & tt, th @@ -1071,7 +1081,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ - REAL, DIMENSION(kts:kte):: vtsk1,prw_vcdc1,prw_vcde1 + REAL, DIMENSION(kts:kte):: vtsk1,prw_vcdc1,prw_vcde1, & + tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & + tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & + tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & + tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & + tprr_rcs1,tprv_rev1,txri1,txrc1 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) @@ -1269,6 +1284,29 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & vtsk1(k) = 0. prw_vcdc1(k) = 0. prw_vcde1(k) = 0. + tpri_inu(k) = 0. + tpri_ide(k) = 0. + tprs_ide(k) = 0. + tprs_sde(k) = 0. + tprg_gde(k) = 0. + tpri_iha(k) = 0. + tpri_wfz(k) = 0. + tpri_rfz(k) = 0. + tprg_rfz(k) = 0. + tprs_scw(k) = 0. + tprg_scw(k) = 0. + tprs_scw(k) = 0. + tprg_rcs(k) = 0. + tprs_rcs(k) = 0. + tprr_rci(k) = 0. + tprg_rcg(k) = 0. + tprw_vcd(k) = 0. + tprr_sml(k) = 0. + tprr_gml(k) = 0. + tprr_rcg(k) = 0. + tprr_rcs(k) = 0. + tprv_rev(k) = 0. + enddo if (is_aerosol_aware) then do k = kts, kte @@ -1292,7 +1330,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1) + kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1, & + tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & + tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & + tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & + tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & + tprr_rcs1,tprv_rev1,txri1,txrc1) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1349,7 +1392,30 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & vts1(i,k,j) = vtsk1(k) prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) - + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide(i,k,j) = tpri_ide(i,k,j) + tpri_ide1(k) + tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) + tprs_sde(i,k,j) = tprs_sde(i,k,j) + tprs_sde1(k) + tprg_gde(i,k,j) = tprg_gde(i,k,j) + tprg_gde1(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) + tprw_vcd(i,k,j) = tprw_vcd(i,k,j) + tprw_vcd1(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) + tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + txri(i,k,j) = txri(i,k,j) + txri1(k) + txrc(i,k,j) = txrc(i,k,j) + txrc1(k) if (present(tt)) then; tt(i,k,j) = t1d(k) else @@ -1563,7 +1629,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rainprod, evapprod, & #endif rand1, rand2, rand3, & - kts, kte, dt, ii, jj, vtsk1, prw_vcdc1, prw_vcde1) + kts, kte, dt, ii, jj, vtsk1, prw_vcdc1, prw_vcde1,& + tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & + tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & + tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & + tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & + tprr_rcs1,tprv_rev1,txri1,txrc1) #ifdef MPI use mpi #endif @@ -1578,8 +1649,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 - REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1,prw_vcdc1,prw_vcde1 - + REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1,prw_vcdc1,prw_vcde1, & + tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & + tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & + tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & + tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & + tprr_rcs1,tprv_rev1,txri1,txrc1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod @@ -1780,6 +1855,31 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_rcd(k) = 0. pnd_scd(k) = 0. pnd_gcd(k) = 0. +!Diagnostics + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1(k) = 0. + tprg_gde1(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprs_scw1(k) = 0. + tprg_scw1(k) = 0. + tprs_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. enddo #if ( WRF_CHEM == 1 ) do k = kts, kte @@ -3377,8 +3477,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtck(k) = 0. vtnck(k) = 0. vtsk1(k) = 0. - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. enddo if (ANY(L_qr .eqv. .true.)) then @@ -3710,6 +3808,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qiten(k) = qiten(k) - xri*odt niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) +!diag + txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) endif xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) @@ -3721,6 +3821,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qcten(k) = qcten(k) - xrc*odt ncten(k) = ncten(k) - xnc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) +!diag + txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT endif enddo endif @@ -3805,8 +3907,31 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif(prw_vcd(k).lt.0)then prw_vcde1(k) = -1*prw_vcd(k)*dt endif +!heating terms + tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tpri_ide1(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tprs_sde1(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tprg_gde1(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprw_vcd1(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT +! cooling terms + tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_rcg1(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_rcs1(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT enddo - end subroutine mp_thompson !>@} From 6a0e904eadd35bd201e9848f68d025a3b8b7db51 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 27 May 2021 15:13:38 +0000 Subject: [PATCH 113/165] Omission from previous revert. --- physics/dcyc2.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 6247f360f..0e3a4db42 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -217,7 +217,7 @@ subroutine dcyc2t3_run & & pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres, minGPtemp, lfnc_k, lfnc_p0 + & deltim, fhswr, minGPpres, lfnc_k, lfnc_p0 real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & From 41782f1170b332a8c5e0c9324c83df48fb6df1b2 Mon Sep 17 00:00:00 2001 From: Dustin Swales Date: Thu, 27 May 2021 17:03:13 +0000 Subject: [PATCH 114/165] Change from PR review. --- physics/dcyc2.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/dcyc2.f b/physics/dcyc2.f index 0e3a4db42..dfa9f02ed 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -421,7 +421,7 @@ subroutine dcyc2t3_run & ! Add radiative heating rates to physics heating rate. Optionally, scaled w/ height ! using a logistic function if (damp_LW_fluxadj) then - lfnc = L / (1+exp(-lfnc_k*(p_lev(i,k) - lfnc_p0))) + lfnc = L / (1+exp(-(p_lev(i,k) - lfnc_p0)/lfnc_k)) else lfnc = 1. endif From bed383fe6b65ef564c539f82c21c0e76e27a4f64 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Fri, 28 May 2021 23:28:03 +0000 Subject: [PATCH 115/165] additional thompson diagnostics coded up --- physics/module_mp_thompson.F90 | 395 +++++++++++++++++++++++---------- physics/mp_thompson.F90 | 92 +++++++- 2 files changed, 363 insertions(+), 124 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index b66bdc44a..592a82c62 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1019,12 +1019,19 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims errmsg, errflg, reset, vts1, prw_vcdc, & - prw_vcde, tpri_inu, tpri_ide, tprs_ide, & - tprs_sde, tprg_gde, tpri_iha, tpri_wfz, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide_d, tprs_ide_s, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprs_scw, tprg_rcs, tprs_rcs, tprr_rci, & - tprg_rcg, tprw_vcd, tprr_sml, tprr_gml, & - tprr_rcg, tprr_rcs, tprv_rev, txri,txrc) + tprg_rcs, tprs_rcs_s, tprs_rcs_r, & + tprr_rci, tprg_rcg_g, tprg_rcg_r, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg_r, tprr_rcg_g, & + tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & + txrc, tten3, qvten3, qrten3, qsten3, & + qgten3, qiten3, niten3, nrten3, ncten3, & + qcten3) implicit none @@ -1035,13 +1042,20 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & qv, qc, qr, qi, qs, qg, ni, nr REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - vts1,prw_vcdc,prw_vcde, & - tpri_inu,tpri_ide,tprs_ide,tprs_sde,tprg_gde, & - tpri_iha,tpri_wfz,tpri_rfz,tprg_rfz,tprs_scw, & - tprg_scw,tprs_scw,tprg_rcs,tprs_rcs,tprr_rci, & - tprg_rcg,tprw_vcd,tprr_sml,tprr_gml,tprr_rcg, & - tprr_rcs,tprv_rev,txri,txrc - + vts1, prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide_d, tprs_ide_s, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs_s, tprs_rcs_r, & + tprr_rci, tprg_rcg_g, tprg_rcg_r, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg_r, tprr_rcg_g, & + tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & + txrc, tten3, qvten3, qrten3, qsten3, & + qgten3, qiten3, niten3, nrten3, ncten3, & + qcten3 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & tt, th REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(IN):: & @@ -1081,12 +1095,21 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ - REAL, DIMENSION(kts:kte):: vtsk1,prw_vcdc1,prw_vcde1, & - tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & - tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & - tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & - tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & - tprr_rcs1,tprv_rev1,txri1,txrc1 + REAL, DIMENSION(kts:kte):: & + vtsk1, prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & + tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & + tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, & + qcten1 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) @@ -1281,32 +1304,52 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + vtsk1(k) = 0. prw_vcdc1(k) = 0. prw_vcde1(k) = 0. - tpri_inu(k) = 0. - tpri_ide(k) = 0. - tprs_ide(k) = 0. - tprs_sde(k) = 0. - tprg_gde(k) = 0. - tpri_iha(k) = 0. - tpri_wfz(k) = 0. - tpri_rfz(k) = 0. - tprg_rfz(k) = 0. - tprs_scw(k) = 0. - tprg_scw(k) = 0. - tprs_scw(k) = 0. - tprg_rcs(k) = 0. - tprs_rcs(k) = 0. - tprr_rci(k) = 0. - tprg_rcg(k) = 0. - tprw_vcd(k) = 0. - tprr_sml(k) = 0. - tprr_gml(k) = 0. - tprr_rcg(k) = 0. - tprr_rcs(k) = 0. - tprv_rev(k) = 0. - + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1_d(k) = 0. + tprs_ide1_s(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprg_scw1(k) = 0. + tprs_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1_s(k) = 0. + tprs_rcs1_r(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1_g(k) = 0. + tprg_rcg1_r(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1_r(k) = 0. + tprr_rcg1_g(k) = 0. + tprr_rcs1_r(k) = 0. + tprr_rcs1_s(k) = 0. + tprv_rev1(k) = 0. + txrc1(k) = 0. + txri1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. enddo if (is_aerosol_aware) then do k = kts, kte @@ -1331,11 +1374,16 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & #endif rand1, rand2, rand3, & kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1, & - tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & - tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & - tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & - tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & - tprr_rcs1,tprv_rev1,txri1,txrc1) + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& + tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & + tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & + tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& + txri1, txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1389,33 +1437,48 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg(i,k,j) = qg1d(k) ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) - vts1(i,k,j) = vtsk1(k) - prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) - prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) - tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) - tpri_ide(i,k,j) = tpri_ide(i,k,j) + tpri_ide1(k) - tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) - tprs_sde(i,k,j) = tprs_sde(i,k,j) + tprs_sde1(k) - tprg_gde(i,k,j) = tprg_gde(i,k,j) + tprg_gde1(k) - tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) - tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) - tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) - tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) - tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) - tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) - tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) - tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) - tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) - tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) - tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) - tprw_vcd(i,k,j) = tprw_vcd(i,k,j) + tprw_vcd1(k) - tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) - tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) - tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) - tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) - tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) - txri(i,k,j) = txri(i,k,j) + txri1(k) - txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + vts1(i,k,j) = vtsk1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) + tprs_ide_d(i,k,j) = tprs_ide_d(i,k,j) + tprs_ide1_d(k) + tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) + tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs_s(i,k,j) = tprs_rcs_s(i,k,j) + tprs_rcs1_s(k) + tprs_rcs_r(i,k,j) = tprs_rcs_r(i,k,j) + tprs_rcs1_r(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg_g(i,k,j) = tprg_rcg_g(i,k,j) + tprg_rcg1_g(k) + tprg_rcg_r(i,k,j) = tprg_rcg_r(i,k,j) + tprg_rcg1_r(k) + tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) + tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg_r(i,k,j) = tprr_rcg_r(i,k,j) + tprr_rcg1_r(k) + tprr_rcg_g(i,k,j) = tprr_rcg_g(i,k,j) + tprr_rcg1_g(k) + tprr_rcs_r(i,k,j) = tprr_rcs_r(i,k,j) + tprr_rcs1_r(k) + tprr_rcs_s(i,k,j) = tprr_rcs_s(i,k,j) + tprr_rcs1_s(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + txri(i,k,j) = txri(i,k,j) + txri1(k) + txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + tten3(i,k,j) = tten3(i,k,j) + tten1(k) + qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) + qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) + qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) + qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) + qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) + niten3(i,k,j) = niten3(i,k,j) + niten1(k) + nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) + ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) + qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) if (present(tt)) then; tt(i,k,j) = t1d(k) else @@ -1629,12 +1692,17 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rainprod, evapprod, & #endif rand1, rand2, rand3, & - kts, kte, dt, ii, jj, vtsk1, prw_vcdc1, prw_vcde1,& - tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & - tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & - tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & - tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & - tprr_rcs1,tprv_rev1,txri1,txrc1) + kts, kte, dt, ii, jj,vtsk1, prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& + tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & + tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & + tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& + txri1, txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1) #ifdef MPI use mpi #endif @@ -1649,12 +1717,21 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 - REAL, DIMENSION(kts:kte), INTENT(OUT):: vtsk1,prw_vcdc1,prw_vcde1, & - tpri_inu1,tpri_ide1,tprs_ide1,tprs_sde1,tprg_gde1, & - tpri_iha1,tpri_wfz1,tpri_rfz1,tprg_rfz1,tprs_scw1, & - tprg_scw1,tprs_scw1,tprg_rcs1,tprs_rcs1,tprr_rci1, & - tprg_rcg1,tprw_vcd1,tprr_sml1,tprr_gml1,tprr_rcg1, & - tprr_rcs1,tprv_rev1,txri1,txrc1 + REAL, DIMENSION(kts:kte), INTENT(OUT):: & + vtsk1, prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & + tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & + tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, & + qcten1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod @@ -1856,30 +1933,51 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_scd(k) = 0. pnd_gcd(k) = 0. !Diagnostics - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. - tpri_inu1(k) = 0. - tpri_ide1(k) = 0. - tprs_ide1(k) = 0. - tprs_sde1(k) = 0. - tprg_gde1(k) = 0. - tpri_iha1(k) = 0. - tpri_wfz1(k) = 0. - tpri_rfz1(k) = 0. - tprg_rfz1(k) = 0. - tprs_scw1(k) = 0. - tprg_scw1(k) = 0. - tprs_scw1(k) = 0. - tprg_rcs1(k) = 0. - tprs_rcs1(k) = 0. - tprr_rci1(k) = 0. - tprg_rcg1(k) = 0. - tprw_vcd1(k) = 0. - tprr_sml1(k) = 0. - tprr_gml1(k) = 0. - tprr_rcg1(k) = 0. - tprr_rcs1(k) = 0. - tprv_rev1(k) = 0. + vtsk1(k) = 0. + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1_d(k) = 0. + tprs_ide1_s(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprg_scw1(k) = 0. + tprs_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1_s(k) = 0. + tprs_rcs1_r(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1_g(k) = 0. + tprg_rcg1_r(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1_r(k) = 0. + tprr_rcg1_g(k) = 0. + tprr_rcs1_r(k) = 0. + tprr_rcs1_s(k) = 0. + tprv_rev1(k) = 0. + txrc1(k) = 0. + txri1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. enddo #if ( WRF_CHEM == 1 ) do k = kts, kte @@ -3907,30 +4005,87 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & elseif(prw_vcd(k).lt.0)then prw_vcde1(k) = -1*prw_vcd(k)*dt endif -!heating terms +!heating/cooling diagnostics tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tpri_ide1(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tprs_sde1(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tprg_gde1(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + + if(pri_ide(k).gt.0)then + tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prs_ide(k).gt.0)then + tprs_ide1_d(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_ide1_s(k) = -prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prs_sde(k).gt.0)then + tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prg_gde(k).gt.0)then + tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + + if(prs_rcs(k).gt.0)then + tprs_rcs1_s(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_rcs1_r(k) = -prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif + tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprw_vcd1(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + + if(prg_rcg(k).gt.0)then + tprg_rcg1_g(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + else + tprg_rcg1_r(k) = -prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prw_vcd(k).gt.0)then + tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + else + tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + endif + ! cooling terms tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - tprr_rcg1(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - tprr_rcs1(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + + if(prr_rcg(k).gt.0)then + tprr_rcg1_r(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + else + tprr_rcg1_g(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prr_rcs(k).gt.0)then + tprr_rcs1_r(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + else + tprr_rcs1_s(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif + tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT + tten1(k) = tten(k)*DT + qvten1(k) = qvten(k)*DT + qrten1(k) = qrten(k)*DT + qsten1(k) = qsten(k)*DT + qgten1(k) = qgten(k)*DT + niten1(k) = niten1(k)*DT + nrten1(k) = nrten1(k)*DT + ncten1(k) = ncten1(k)*DT + qcten1(k) = qcten1(k)*DT enddo end subroutine mp_thompson !>@} diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index daa492aa9..ddb0c900d 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -570,7 +570,28 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & + tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & + tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & + tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & + tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & + tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & + tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & + tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & + tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & + tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & + tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & + tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & + tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & + tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & + tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & + tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & + txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & + qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & + qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & + qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & + nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & + qcten3=aux3d(:,:,45)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -590,7 +611,28 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & + tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & + tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & + tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & + tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & + tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & + tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & + tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & + tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & + tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & + tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & + tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & + tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & + tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & + tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & + tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & + txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & + qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & + qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & + qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & + nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & + qcten3=aux3d(:,:,45)) end if else if (do_effective_radii) then @@ -612,7 +654,28 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & + tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & + tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & + tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & + tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & + tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & + tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & + tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & + tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & + tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & + tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & + tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & + tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & + tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & + tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & + tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & + txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & + qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & + qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & + qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & + nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & + qcten3=aux3d(:,:,45)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -631,7 +694,28 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & errmsg=errmsg, errflg=errflg, reset=reset, vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3)) + prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & + tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & + tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & + tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & + tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & + tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & + tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & + tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & + tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & + tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & + tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & + tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & + tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & + tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & + tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & + tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & + txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & + qvten3=aux3d(:,:,37), qrten3=aux3d(:,:,38), & + qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & + qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & + nrten3=aux3d(:,:,43), ncten3=aux3d(:,:,44), & + qcten3=aux3d(:,:,45)) end if end if if (errflg/=0) return From 094e7dbc9442f9502a9a7210472539bec24e74e6 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Fri, 28 May 2021 23:40:27 +0000 Subject: [PATCH 116/165] fix bug with some diagnostics --- physics/module_mp_thompson.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 592a82c62..4609849e7 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -4082,10 +4082,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qrten1(k) = qrten(k)*DT qsten1(k) = qsten(k)*DT qgten1(k) = qgten(k)*DT - niten1(k) = niten1(k)*DT - nrten1(k) = nrten1(k)*DT - ncten1(k) = ncten1(k)*DT - qcten1(k) = qcten1(k)*DT + niten1(k) = niten(k)*DT + nrten1(k) = nrten(k)*DT + ncten1(k) = ncten(k)*DT + qcten1(k) = qcten(k)*DT enddo end subroutine mp_thompson !>@} From c7fa4b940f8aa643d9a75f833beb4159138877cb Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Tue, 1 Jun 2021 12:38:23 +0000 Subject: [PATCH 117/165] Updated TKE-EDMF for surface flux output --- physics/satmedmfvdifq.F | 31 +++++++++++++------------------ 1 file changed, 13 insertions(+), 18 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index a59c43e53..206c64456 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -179,11 +179,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & ucko(im,km), vcko(im,km), & buou(im,km), xmf(im,km) ! -! temporary local variables for instantaneous surface fluxes -! (they will be removed later) -! - real(kind=kind_phys) dusfc1(im),dvsfc1(im),dtsfc1(im),dqsfc1(im) -! ! variables for stratocumulus-top induced downdrafts ! real(kind=kind_phys) tcdo(im,km), qcdo(im,km,ntrac), @@ -199,7 +194,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & real(kind=kind_phys) aphi16, aphi5, & wfac, cfac, & gamcrt, gamcrq, sfcfrac, - & conq, cont, conw, +! & conq, cont, conw, & dsdz2, dsdzt, dkmax, & dsig, dt2, dtodsd, & dtodsu, g, factor, dz, @@ -256,10 +251,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & gravi=1.0/grav g=grav gocp=g/cp - cont=cp/g - conq=hvap/g - conw=1.0/g ! for del in pa -! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa +! cont=cp/g +! conq=hvap/g +! conw=1.0/g ! for del in pa +!! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa elocp=hvap/cp el2orc=hvap*hvap/(rv*cp) ! @@ -385,10 +380,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & do i = 1,im z0(i) = 0.01 * zorl(i) rho_a(i) = prsl(i,1)/(rd*t1(i,1)*(1.+fv*max(q1(i,1,1),qmin))) - dusfc1(i) = 0. - dvsfc1(i) = 0. - dtsfc1(i) = 0. - dqsfc1(i) = 0. + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. kpbl(i) = 1 hpbl(i) = 0. kpblx(i) = 1 @@ -1484,8 +1479,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend rtg(i,k,1) = rtg(i,k,1)+qtend - dtsfc1(i) = dtsfc1(i)+cont*del(i,k)*ttend - dqsfc1(i) = dqsfc1(i)+conq*del(i,k)*qtend +! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend +! dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo do i = 1,im @@ -1623,8 +1618,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k)+utend dv(i,k) = dv(i,k)+vtend - dusfc1(i) = dusfc1(i)+conw*del(i,k)*utend - dvsfc1(i) = dvsfc1(i)+conw*del(i,k)*vtend +! dusfc(i) = dusfc(i)+conw*del(i,k)*utend +! dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo do i = 1,im From 3a15650fc372e2e61f7dc2ab1861b48682eb99d3 Mon Sep 17 00:00:00 2001 From: Raffaele Montuoro Date: Thu, 3 Jun 2021 19:11:07 +0000 Subject: [PATCH 118/165] Fill coupling array holding instantaneous surface temperature values when coupling with chemistry model. --- physics/GFS_surface_generic.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 42e7c4e5d..9fa75dea1 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -281,6 +281,12 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, enddo endif + if (cplflx .or. cplchm) then + do i=1,im + tsfci_cpl(i) = tsfc(i) + enddo + endif + if (cplflx) then do i=1,im dlwsfci_cpl (i) = adjsfcdlw(i) @@ -302,8 +308,6 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, icy, nlwsfc_cpl (i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf t2mi_cpl (i) = t2m(i) q2mi_cpl (i) = q2m(i) - tsfci_cpl (i) = tsfc(i) -! tsfci_cpl (i) = tsfc_wat(i) psurfi_cpl (i) = pgr(i) enddo From cd548906c661a156bb6a98ee53ac534e24b38451 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 16:37:48 +0000 Subject: [PATCH 119/165] add zvfun as intent out --- physics/sfc_diff.meta | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index c0d448655..f079b4357 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -96,6 +96,15 @@ kind = kind_phys intent = in optional = F +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level From fce8641a5bcc71c5db6c73fda2a21f3a73ddf5ce Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 16:38:38 +0000 Subject: [PATCH 120/165] define zvfun as intent out --- physics/GFS_surface_generic.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 053613913..145c9f82c 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -1335,7 +1335,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = in optional = F [hffac] standard_name = surface_upward_sensible_heat_flux_reduction_factor From bfcacf6f8a3099daf362b2b1293a8b77c803fde7 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 17:08:02 +0000 Subject: [PATCH 121/165] add zvfun as intent out --- physics/sfc_diff.f | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 9cd6050c4..d797e2176 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -84,6 +84,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm10_wat, fm10_lnd, fm10_ice, & !intent(inout) & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) & ztmax_wat, ztmax_lnd, ztmax_ice, & !intent(inout) + & zvfun, & !intent(out) & errmsg, errflg) !intent(out) ! implicit none @@ -122,6 +123,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm10_wat, fm10_lnd, fm10_ice, & & fh2_wat, fh2_lnd, fh2_ice, & & ztmax_wat, ztmax_lnd, ztmax_ice + real(kind=kind_phys), dimension(:), intent(out) :: zvfun ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -134,7 +136,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & czilc, tem1, tem2, virtfac ! - real(kind=kind_phys) :: tvs, z0, z0max, ztmax, zvfun, gdx + real(kind=kind_phys) :: tvs, z0, z0max, ztmax, gdx ! real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 ! @@ -189,7 +191,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) thv1 = t1(i) / prslk1(i) * virtfac endif - zvfun = zero + zvfun(i) = zero gdx = sqrt(garea(i)) ! compute stability dependent exchange coefficients @@ -269,15 +271,17 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ztmax_lnd(i) = ztmax_lnd(i) * (10.0_kp**ztpert(i)) endif ztmax_lnd(i) = max(ztmax_lnd(i), zmin) +! +! compute a function of surface roughness & green vegetation fraction (zvfun) ! tem1 = (z0max - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, zero), 1.0_kp) tem2 = max(sigmaf(i), 0.1_kp) - zvfun = sqrt(tem1 * tem2) + zvfun(i) = sqrt(tem1 * tem2) ! call stability ! --- inputs: - & (z1(i), zvfun, gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), @@ -327,7 +331,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun, gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), @@ -378,7 +382,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun, gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_wat(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), From 70c1e55368f753928c454daccce6c3de232e8947 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 17:20:00 +0000 Subject: [PATCH 122/165] update of GFS_surface_generic_post --- physics/GFS_surface_generic.F90 | 33 +++++++-------------------------- 1 file changed, 7 insertions(+), 26 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 6b62b2865..b7e3843fb 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -215,8 +215,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & - nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, islmsk, sigmaf, & - runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zorl, hflx, evap, hflxq, zvfun, hffac, errmsg, errflg) + nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, islmsk, & + runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, errmsg, errflg) implicit none @@ -237,15 +237,15 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt evcwa, transa, sbsnoa, snowca, snohfa, ep real(kind=kind_phys), dimension(:), intent(inout) :: runoff, srunoff - real(kind=kind_phys), dimension(:), intent(in) :: drain, runof, sigmaf + real(kind=kind_phys), dimension(:), intent(in) :: drain, runof ! For canopy heat storage logical, intent(in) :: lheatstrg real(kind=kind_phys), intent(in) :: h0facu, h0facs - real(kind=kind_phys), dimension(:), intent(in) :: zorl + real(kind=kind_phys), dimension(:), intent(in) :: zvfun real(kind=kind_phys), dimension(:), intent(in) :: hflx, evap real(kind=kind_phys), dimension(:), intent(out) :: hflxq - real(kind=kind_phys), dimension(:), intent(out) :: zvfun, hffac + real(kind=kind_phys), dimension(:), intent(out) :: hffac ! CCPP error handling variables character(len=*), intent(out) :: errmsg @@ -254,12 +254,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! Local variables real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys - ! Parameters for canopy heat storage parametrization - real(kind=kind_phys), parameter :: z0min=0.1, z0max=1.0 - integer :: i real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl - real(kind=kind_phys) :: tem, tem1, tem2 ! Initialize CCPP error handling variables errmsg = '' @@ -364,24 +360,9 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! in order to achieve heat storage within canopy layer, in the canopy ! heat torage parameterization the kinematic sensible heat flux ! (hflx) as surface boundary forcing to the pbl scheme is -! reduced as a function of surface roughness & green vegetation -! fraction -! -! background diffusivity & background mixing length are also given by -! a function of surface roughness & green vegetation fraction +! reduced in a factor of hffac given as a function of surface roughness & +! green vegetation fraction (zvfun) ! - do i=1,im - if(islmsk(i) == 1) then - tem = 0.01 * zorl(i) ! change unit from cm to m - tem1 = (tem - z0min) / (z0max - z0min) - tem1 = min(max(tem1, 0.0), 1.0) - tem2 = max(sigmaf(i), 0.1) -! tem2 = sigmaf(i) - zvfun(i) = sqrt(tem1 * tem2) - else - zvfun(i) = 0. - endif - enddo do i=1,im hflxq(i) = hflx(i) hffac(i) = 1.0 From d111179b8c0e317353048cd03df03b17920c8119 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 17:22:31 +0000 Subject: [PATCH 123/165] update of GFS_surface_generic.meta --- physics/GFS_surface_generic.meta | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 145c9f82c..e6393f228 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -1221,15 +1221,6 @@ type = integer intent = in optional = F -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [runoff] standard_name = total_runoff long_name = total water runoff @@ -1292,15 +1283,6 @@ kind = kind_phys intent = in optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [hflx] standard_name = kinematic_surface_upward_sensible_heat_flux long_name = kinematic surface upward sensible heat flux From 44a6088c6e9eb1964e851c7c4c16554c3b118eb4 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 18:17:43 +0000 Subject: [PATCH 124/165] update of GFS_surface_composites.F90 with zvfun --- physics/GFS_surface_composites.F90 | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index ee99e0f85..31becefa4 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -375,14 +375,14 @@ end subroutine GFS_surface_composites_post_finalize !! subroutine GFS_surface_composites_post_run ( & im, kice, km, rd, rvrdm1, cplflx, cplwav2atm, frac_grid, flag_cice, thsfc_loc, islmsk, dry, wet, icy, wind, t1, q1, prsl1, & - landfrac, lakefrac, oceanfrac, zorl, zorlo, zorll, zorli, & + landfrac, lakefrac, oceanfrac, zorl, zorlo, zorll, zorli, garea, & cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, & cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, sigmaf, zvfun, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) implicit none @@ -397,13 +397,14 @@ subroutine GFS_surface_composites_post_run ( fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & - hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli + hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli, garea real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & fh2, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc real(kind=kind_phys), dimension(:), intent(in ) :: tice ! interstitial sea ice temperature real(kind=kind_phys), dimension(:), intent(inout) :: hice, cice + real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun real(kind=kind_phys), intent(in ) :: min_seaice real(kind=kind_phys), intent(in ) :: rd, rvrdm1 @@ -424,6 +425,10 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys) :: txl, txi, txo, wfrac, q0, rho ! For calling "stability" real(kind=kind_phys) :: tsurf, virtfac, tv1, thv1, tvs, z0max, ztmax +! + real(kind=kind_phys) :: tem1, tem2, gdx + real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 +! ! Initialize CCPP error handling variables errmsg = '' @@ -448,6 +453,8 @@ subroutine GFS_surface_composites_post_run ( weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) +! + sigmaf(i) = txl*sigmaf(i) if (.not. flag_cice(i) .and. islmsk(i) == 2) then evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) @@ -524,8 +531,17 @@ subroutine GFS_surface_composites_post_run ( stress(i) = stress_ice(i) uustar(i) = uustar_ice(i) else ! Mix of multiple surface types (land, water, and/or ice) - call stability(z1(i), snowd(i), thv1, wind(i), z0max, ztmax, tvs, grav, & ! inputs - tv1, thsfc_loc, & ! inputs +! +! compute zvfun with composite surface roughness & green vegetation fraction +! + tem1 = (z0max - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, zero), one) + tem2 = max(sigmaf(i), 0.1) + zvfun(i) = sqrt(tem1 * tem2) + gdx = sqrt(garea(i)) +! + call stability(z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & ! inputs + z0max, ztmax, tvs, grav, thsfc_loc, & ! inputs rb(i), ffmm(i), ffhh(i), fm10(i), fh2(i), cd(i), cdq(i), & ! outputs stress(i), uustar(i)) endif ! Checking to see if point is one or multiple surface types From 847cf62a8233bfd8f0ee6bc8766b96b63b63483e Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 4 Jun 2021 18:20:55 +0000 Subject: [PATCH 125/165] update of GFS_surface_composites.meta with zvfun, sigmaf, & garea --- physics/GFS_surface_composites.meta | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 95f2c6e4e..88dae1ae4 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -1919,6 +1919,33 @@ kind = kind_phys intent = in optional = F +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[sigmaf] + standard_name = bounded_vegetation_area_fraction + long_name = areal fractional cover of green vegetation bounded on the bottom + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [ztmax_wat] standard_name = bounded_surface_roughness_length_for_heat_over_water long_name = bounded surface roughness length for heat over water From 466d4b4d034b8a57fed906219bea1be80c7fe38e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 8 Jun 2021 19:18:54 +0000 Subject: [PATCH 126/165] adding snow depth and weasd over land to SfcProps and fixing some issues associated with fractional grid --- physics/GFS_phys_time_vary.fv3.F90 | 16 +- physics/GFS_surface_composites.F90 | 121 +- physics/GFS_surface_composites.meta | 44 +- physics/GFS_surface_generic.F90 | 47 +- physics/GFS_surface_generic.meta | 2 +- physics/debug/GFS_MP_generic.F90_dbg | 403 - physics/debug/GFS_MP_generic.meta_dbg | 905 -- physics/debug/GFS_suite_interstitial.F90_dbg | 850 -- physics/debug/GFS_suite_interstitial.meta_dbg | 2014 ---- physics/debug/GFS_surface_composites.F90_dbg | 678 -- physics/debug/GFS_surface_composites.meta_dbg | 1865 ---- physics/debug/GFS_surface_generic.F90_dbg | 400 - physics/debug/GFS_surface_generic.meta_dbg | 1354 --- physics/debug/gcycle.F90_dbg | 257 - physics/debug/sfc_diff.f_dbg | 779 -- physics/debug/sfc_diff.meta_dbg | 653 -- physics/debug/sfc_drv.f_dbg | 666 -- physics/debug/sfc_drv.meta_dbg | 788 -- physics/debug/sfc_sice.f_dbg | 772 -- physics/debug/sfc_sice.meta_dbg | 478 - physics/debug/sfcsub.F_dbg | 8772 ----------------- physics/flake_driver.meta | 8 +- physics/module_MYNNSFC_wrapper.F90 | 21 +- physics/module_MYNNSFC_wrapper.meta | 9 - physics/sfc_diff.f | 10 +- physics/sfc_diff.meta | 9 - 26 files changed, 130 insertions(+), 21791 deletions(-) delete mode 100644 physics/debug/GFS_MP_generic.F90_dbg delete mode 100644 physics/debug/GFS_MP_generic.meta_dbg delete mode 100644 physics/debug/GFS_suite_interstitial.F90_dbg delete mode 100644 physics/debug/GFS_suite_interstitial.meta_dbg delete mode 100644 physics/debug/GFS_surface_composites.F90_dbg delete mode 100644 physics/debug/GFS_surface_composites.meta_dbg delete mode 100644 physics/debug/GFS_surface_generic.F90_dbg delete mode 100644 physics/debug/GFS_surface_generic.meta_dbg delete mode 100644 physics/debug/gcycle.F90_dbg delete mode 100644 physics/debug/sfc_diff.f_dbg delete mode 100644 physics/debug/sfc_diff.meta_dbg delete mode 100644 physics/debug/sfc_drv.f_dbg delete mode 100644 physics/debug/sfc_drv.meta_dbg delete mode 100644 physics/debug/sfc_sice.f_dbg delete mode 100644 physics/debug/sfc_sice.meta_dbg delete mode 100644 physics/debug/sfcsub.F_dbg diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 2103f81a9..20c6c68c3 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -75,7 +75,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -897,13 +897,13 @@ subroutine GFS_phys_time_vary_timestep_init ( !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (nscyc > 0) then if (mod(kdt,nscyc) == 1) THEN - call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice, & - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & xlat_d, xlon_d, slmsk, imap, jmap) endif endif diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index fd15fea9a..b45b64629 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -29,19 +29,19 @@ end subroutine GFS_surface_composites_pre_finalize !! subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, lsm_ruc, frac_grid, & flag_cice, cplflx, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, lake, use_flake, ocean, wet, hice, cice, zorlo, zorll, zorli, & - snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + dry, icy, lake, use_flake, ocean, wet, hice, cice, zorlo, zorll, zorli, & + snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_lnd, tsfc_ice, tisfc, tice, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & - min_lakeice, min_seaice, errmsg, errflg) + min_lakeice, min_seaice, kdt, errmsg, errflg) implicit none ! Interface variables - integer, intent(in ) :: im, lkm + integer, intent(in ) :: im, lkm, kdt integer, intent(in ) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in ) :: flag_init, frac_grid, cplflx, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice @@ -52,9 +52,9 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss, hflx real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc - real(kind=kind_phys), dimension(:), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & + real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(:), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice @@ -68,6 +68,8 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, ! real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + real(kind=kind_phys) :: tem + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -102,6 +104,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -116,6 +119,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, cice(i) = zero hice(i) = zero islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) flag_cice(i) = .false. @@ -129,6 +133,9 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, hice(i) = zero islmsk_cice(i) = 1 islmsk(i) = 1 + wet(i) = .false. + icy(i) = .false. + flag_cice(i) = .false. endif enddo @@ -141,6 +148,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, frland(i) = one cice(i) = zero hice(i) = zero + icy(i) = .false. else frland(i) = zero if (oceanfrac(i) > zero) then @@ -161,6 +169,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -175,6 +184,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, cice(i) = zero hice(i) = zero islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) flag_cice(i) = .false. @@ -195,10 +205,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, ! uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) -! weasd_wat(i) = weasd(i) -! snowd_wat(i) = snowd(i) - weasd_wat(i) = zero - snowd_wat(i) = zero !-- reference emiss value for surface emissivity in setemis ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow @@ -214,7 +220,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, weasd_lnd(i) = weasd(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) - snowd_lnd(i) = snowd(i) if (iemsflg == 2 .and. .not. flag_init) then !-- use land emissivity from the LSM semis_lnd(i) = emis_lnd(i) @@ -231,7 +236,6 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, weasd_ice(i) = weasd(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) -! snowd_ice(i) = snowd(i) / cice(i) ep1d_ice(i) = zero gflx_ice(i) = zero if (iemsflg == 2 .and. .not. flag_init .and. lsm == lsm_ruc) then @@ -263,33 +267,43 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, endif enddo ! - if (frac_grid) then - do i=1,im - if (dry(i)) then - if (icy(i)) then - snowd_lnd(i) = snowd(i) / (frland(i) + cice(i)) - snowd_ice(i) = snowd_lnd(i) - else - snowd_lnd(i) = snowd(i) / frland(i) + if (.not. cplflx .or. kdt == 1) then + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + tem = one / (cice(i)*(one-frland(i))) + snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) + weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) + endif + elseif (icy(i)) then + tem = one / cice(i) + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) * tem + weasd_lnd(i) = zero + weasd_ice(i) = weasd(i) * tem + endif + enddo + else + do i=1,im + if (dry(i)) then + snowd_lnd(i) = snowd(i) + weasd_lnd(i) = weasd(i) snowd_ice(i) = zero + weasd_ice(i) = zero + elseif (icy(i)) then + snowd_lnd(i) = zero + weasd_lnd(i) = zero + tem = one / cice(i) + snowd_ice(i) = snowd(i) * tem + weasd_ice(i) = weasd(i) * tem endif - elseif (icy(i)) then - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) / cice(i) - endif - enddo - else - do i=1,im - if (dry(i)) then - snowd_lnd(i) = snowd(i) - snowd_ice(i) = zero - elseif (icy(i)) then - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) / cice(i) - endif - enddo + enddo + endif endif +! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) + ! Assign sea ice temperature to interstitial variable do i = 1, im tice(i) = tisfc(i) @@ -410,7 +424,7 @@ subroutine GFS_surface_composites_post_run ( stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, & cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & - ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + ep1d_lnd, ep1d_ice, weasd, weasd_lnd, weasd_ice, snowd, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) @@ -425,8 +439,8 @@ subroutine GFS_surface_composites_post_run ( cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & - chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & - snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & + chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_lnd, weasd_ice, & + snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & @@ -473,17 +487,22 @@ subroutine GFS_surface_composites_post_run ( !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) - !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_wat(i) - !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_wat(i) weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) - if (.not. flag_cice(i) .and. islmsk(i) == 2) then - evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + if (.not. flag_cice(i)) then + if (islmsk(i) == 2) then + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + else + evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) + endif else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) @@ -660,8 +679,8 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) ep1d(i) = ep1d_wat(i) - weasd(i) = weasd_wat(i) - snowd(i) = snowd_wat(i) + weasd(i) = zero + snowd(i) = zero evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) @@ -682,8 +701,8 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) ep1d(i) = ep1d_ice(i) - weasd(i) = weasd_ice(i) - snowd(i) = snowd_ice(i) + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) qss(i) = qss_ice(i) tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) @@ -704,7 +723,7 @@ subroutine GFS_surface_composites_post_run ( zorl(i) = txi * zorli(i) + txo * zorlo(i) ! zorl(i) = txi * log(zorli(i)) + txo * log(zorlo(i)) ! zorl(i) = exp(zorl(i)) - snowd(i) = txi * snowd_ice(i) +! snowd(i) = txi * snowd_ice(i) endif elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array zorl(i) = cice(i)*zorli(i) + (one-cice(i))*zorlo(i) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 9a97ed14d..08f66fe2f 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -234,15 +234,6 @@ kind = kind_phys intent = in optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land @@ -342,15 +333,6 @@ kind = kind_phys intent = in optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -664,6 +646,14 @@ kind = kind_phys intent = in optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1559,15 +1549,6 @@ kind = kind_phys intent = inout optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -1595,15 +1576,6 @@ kind = kind_phys intent = inout optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index fd445c9ff..5e28a9aa3 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -56,8 +56,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type - integer, intent(in) :: n_var_lndp + integer, intent(in) :: lndp_type, n_var_lndp character(len=3), dimension(:), intent(in) :: lndp_var_list real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts @@ -67,19 +66,19 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: xlai1d real(kind=kind_phys), dimension(:), intent(out) :: vegf1d real(kind=kind_phys), intent(out) :: lndp_vgf - real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv + real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl - logical, dimension(:), intent(inout) :: flag_cice - integer, dimension(:), intent(out) :: islmsk_cice + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl + logical, dimension(:), intent(inout) :: flag_cice + integer, dimension(:), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(:), intent(out) :: wind - real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 + real(kind=kind_phys), dimension(:), intent(out) :: wind + real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind + real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind ! - real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 + real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -87,8 +86,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Local variables integer :: i, k - real(kind=kind_phys) :: onebg - real(kind=kind_phys) :: cdfz + real(kind=kind_phys) :: onebg, cdfz ! Set constants onebg = 1.0/con_g @@ -97,7 +95,6 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, errmsg = '' errflg = 0 - ! Scale random patterns for surface perturbations with perturbation size ! Turn vegetation fraction pattern into percentile pattern lndp_vgf=-999. @@ -134,20 +131,20 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then - soiltyp(i) = 16 + soiltyp(i) = 16 else - soiltyp(i) = 9 + soiltyp(i) = 9 endif if (ivegsrc == 0 .or. ivegsrc == 4) then - vegtype(i) = 24 + vegtype(i) = 24 elseif (ivegsrc == 1) then - vegtype(i) = 15 + vegtype(i) = 15 elseif (ivegsrc == 2) then - vegtype(i) = 13 + vegtype(i) = 13 elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vegtype(i) = 15 + vegtype(i) = 15 endif - slopetyp(i) = 9 + slopetyp(i) = 9 else soiltyp(i) = int( stype(i)+0.5_kind_phys ) vegtype(i) = int( vtype(i)+0.5_kind_phys ) @@ -165,9 +162,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) cnvwind(i) = zero enddo @@ -310,7 +307,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt do i=1,im ! if (Sfcprop%landfrac(i) < one) then ! Not 100% land - if (wet(i)) then ! some open water + if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) ocalnirdf_cpl = 0.06_kind_phys diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 9ba7c95a3..1db35942e 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -190,7 +190,7 @@ optional = F [dsnow_cpl] standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling - long_name = change in show_cpl (coupling_type) + long_name = change in snow_cpl (coupling_type) units = m dimensions = (horizontal_loop_extent) type = real diff --git a/physics/debug/GFS_MP_generic.F90_dbg b/physics/debug/GFS_MP_generic.F90_dbg deleted file mode 100644 index d2ffbe8c5..000000000 --- a/physics/debug/GFS_MP_generic.F90_dbg +++ /dev/null @@ -1,403 +0,0 @@ -!> \file GFS_MP_generic.F90 -!! This file contains the subroutines that calculate diagnotics variables -!! before/after calling any microphysics scheme: - -!> This module contains the CCPP-compliant MP generic pre interstitial codes. - module GFS_MP_generic_pre - contains - - subroutine GFS_MP_generic_pre_init() - end subroutine GFS_MP_generic_pre_init - -!> \section arg_table_GFS_MP_generic_pre_run Argument Table -!! \htmlinclude GFS_MP_generic_pre_run.html -!! - subroutine GFS_MP_generic_pre_run(im, levs, ldiag3d, qdiag3d, do_aw, ntcw, nncl, ntrac, gt0, gq0, save_t, save_qv, save_q, errmsg, errflg) -! - use machine, only: kind_phys - - implicit none - integer, intent(in) :: im, levs, ntcw, nncl, ntrac - logical, intent(in) :: ldiag3d, qdiag3d, do_aw - real(kind=kind_phys), dimension(im, levs), intent(in) :: gt0 - real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 - - real(kind=kind_phys), dimension(im, levs), intent(inout) :: save_t, save_qv - real(kind=kind_phys), dimension(im, levs, ntrac), intent(inout) :: save_q - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ldiag3d .or. do_aw) then - do k=1,levs - do i=1,im - save_t(i,k) = gt0(i,k) - enddo - enddo - if(qdiag3d) then - do k=1,levs - do i=1,im - ! Here, gq0(...,1) is used instead of gq0_water_vapor - ! to be consistent with the GFS_MP_generic_post_run - ! code. - save_qv(i,k) = gq0(i,k,1) - enddo - enddo - endif - if(do_aw) then - save_q(1:im,:,1) = gq0(1:im,:,1) - do n=ntcw,ntcw+nncl-1 - save_q(1:im,:,n) = gq0(1:im,:,n) - enddo - endif - endif - - end subroutine GFS_MP_generic_pre_run - - subroutine GFS_MP_generic_pre_finalize() - end subroutine GFS_MP_generic_pre_finalize - - end module GFS_MP_generic_pre - -!> This module contains the subroutine that calculates -!! precipitation type and its post, which provides precipitation forcing -!! to LSM. - module GFS_MP_generic_post - contains - - subroutine GFS_MP_generic_post_init() - end subroutine GFS_MP_generic_post_init - -!>\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. -!! -!! \section arg_table_GFS_MP_generic_post_run Argument Table -!! \htmlinclude GFS_MP_generic_post_run.html -!! -!> \section gfs_mp_gen GFS MP Generic Post General Algorithm -!> @{ - subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & - imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, con_g, dtf, frain, rainc, rain1, & - rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_qv, rain0, ice0, snow0, & - graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & - totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, dt3dt, dq3dt, rain_cpl, rainc_cpl, snow_cpl, pwat, & - drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & - graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, lprnt, ipr, errmsg, errflg) -! - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, ipr - integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires - logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, lprnt - - real(kind=kind_phys), intent(in) :: dtf, frain, con_g - real(kind=kind_phys), dimension(im), intent(in) :: rain1, xlat, xlon, tsfc - real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel, rainc - real(kind=kind_phys), dimension(im), intent(in) :: rain0, ice0, snow0, graupel0 - real(kind=kind_phys), dimension(im,nrcm), intent(in) :: rann - real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, prsl, save_t, save_qv, del - real(kind=kind_phys), dimension(im,levs+1), intent(in) :: prsi, phii - real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: gq0 - - real(kind=kind_phys), dimension(im), intent(in ) :: sr - real(kind=kind_phys), dimension(im), intent(inout) :: rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, & - srflag, cnvprcp, totprcp, totice, totsnw, totgrp, cnvprcpb, & - totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, & - snow_cpl, pwat - - real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt ! only if ldiag3d - real(kind=kind_phys), dimension(:,:), intent(inout) :: dq3dt ! only if ldiag3d and qdiag3d - - ! Stochastic physics / surface perturbations - real(kind=kind_phys), dimension(im), intent(inout) :: drain_cpl - real(kind=kind_phys), dimension(im), intent(inout) :: dsnow_cpl - - ! Rainfall variables previous time step - integer, intent(in) :: lsm, lsm_ruc, lsm_noahmp - real(kind=kind_phys), dimension(im), intent(inout) :: raincprv - real(kind=kind_phys), dimension(im), intent(inout) :: rainncprv - real(kind=kind_phys), dimension(im), intent(inout) :: iceprv - real(kind=kind_phys), dimension(im), intent(inout) :: snowprv - real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv - real(kind=kind_phys), dimension(im), intent(inout) :: draincprv - real(kind=kind_phys), dimension(im), intent(inout) :: drainncprv - real(kind=kind_phys), dimension(im), intent(inout) :: diceprv - real(kind=kind_phys), dimension(im), intent(inout) :: dsnowprv - real(kind=kind_phys), dimension(im), intent(inout) :: dgraupelprv - - real(kind=kind_phys), intent(in) :: dtp - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! DH* TODO: CLEANUP, all of these should be coming in through the argument list - real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys - real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys - real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys - real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys - ! *DH - - integer :: i, k, ic - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 - real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - onebg = one/con_g - - do i = 1, im - rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit - enddo - -!> - If requested (e.g. Zhao-Carr MP scheme), call calpreciptype() to calculate dominant -!! precipitation type. - ! DH* TODO - Fix wrong code in non-CCPP build (GFS_physics_driver) - ! and use commented lines here (keep wrong version for bit-for-bit): - ! put ice, snow, graupel on dynamics timestep. The way the code in - ! GFS_physics_driver is written, Diag%{graupel,ice,snow} are on the - ! physics timestep, while Diag%{rain,rainc} and all totprecip etc - ! are on the dynamics timestep. Confusing, but works if frain=1. *DH - if (imp_physics == imp_physics_gfdl) then - tprcp = max(zero, rain) ! clu: rain -> tprcp - !graupel = frain*graupel0 - !ice = frain*ice0 - !snow = frain*snow0 - graupel = graupel0 - ice = ice0 - snow = snow0 - ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson) then - tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip - graupel = frain*graupel0 ! time-step graupel - ice = frain*ice0 ! time-step ice - snow = frain*snow0 ! time-step snow - - else if (imp_physics == imp_physics_fer_hires) then - tprcp = max (zero, rain) ! time-step convective and explicit precip - ice = frain*rain1*sr ! time-step ice - end if - - if (lsm==lsm_ruc .or. lsm==lsm_noahmp) then - raincprv(:) = rainc(:) - rainncprv(:) = frain * rain1(:) - iceprv(:) = ice(:) - snowprv(:) = snow(:) - graupelprv(:) = graupel(:) - !for NoahMP, calculate precipitation rates from liquid water equivalent thickness for use in next time step - !Note (GJF): Precipitation LWE thicknesses are multiplied by the frain factor, and are thus on the dynamics time step, but the conversion as written - ! (with dtp in the denominator) assumes the rate is calculated on the physics time step. This only works as expected when dtf=dtp (i.e. when frain=1). - if (lsm == lsm_noahmp) then - tem = one / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? - draincprv(:) = tem * raincprv(:) - drainncprv(:) = tem * rainncprv(:) - dsnowprv(:) = tem * snowprv(:) - dgraupelprv(:) = tem * graupelprv(:) - diceprv(:) = tem * iceprv(:) - end if - end if - - if (cal_pre) then ! hchuang: add dominant precipitation type algorithm -! - call calpreciptype (kdt, nrcm, im, im, levs, levs+1, & - rann, xlat, xlon, gt0, & - gq0(:,:,1), prsl, prsi, & - rain, phii, tsfc, & ! input - domr, domzr, domip, doms) ! output -! -! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - - if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then - do i=1,im - tprcp(i) = max(zero, rain(i) ) - if(doms(i) > zero .or. domip(i) > zero) then - srflag(i) = one - else - srflag(i) = zero - end if - enddo - endif - if (lssav) then - do i=1,im - domr_diag(i) = domr_diag(i) + domr(i) * dtf - domzr_diag(i) = domzr_diag(i) + domzr(i) * dtf - domip_diag(i) = domip_diag(i) + domip(i) * dtf - doms_diag(i) = doms_diag(i) + doms(i) * dtf - enddo - endif - - endif - - t850(1:im) = gt0(1:im,1) - - do k = 1, levs-1 - do i = 1, im - if (prsl(i,k) > p850 .and. prsl(i,k+1) <= p850) then - t850(i) = gt0(i,k) - (prsl(i,k)-p850) / & - (prsl(i,k)-prsl(i,k+1)) * & - (gt0(i,k)-gt0(i,k+1)) - endif - enddo - enddo - - ! Conversion factor from mm per day to m per physics timestep - tem = dtp * con_p001 / con_day - -!> - For GFDL and Thompson MP scheme, determine convective snow by surface temperature; -!! and determine explicit rain/snow by snow/ice/graupel coming out directly from MP -!! and convective rainfall from the cumulus scheme if the surface temperature is below -!! \f$0^oC\f$. - - if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then - -! determine convective rain/snow by surface temperature -! determine large-scale rain/snow by rain/snow coming out directly from MP - - if (lsm /= lsm_ruc) then - do i = 1, im - !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 - srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (tsfc(i) >= 273.15_kind_phys) then - crain = rainc(i) - csnow = zero - else - crain = zero - csnow = rainc(i) - endif -! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then -! if (snow0(i)+ice0(i)+graupel0(i)+csnow > 0.0) then -! Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) -! endif - total_precip = snow0(i)+ice0(i)+graupel0(i)+rain0(i)+rainc(i) - if (total_precip > rainmin) then - srflag(i) = (snow0(i)+ice0(i)+graupel0(i)+csnow)/total_precip - endif - enddo - else - ! only for RUC LSM - do i=1,im - srflag(i) = sr(i) - enddo - endif ! lsm==lsm_ruc - elseif( .not. cal_pre) then - if (imp_physics == imp_physics_mg) then ! MG microphysics - do i=1,im - if (rain(i) > rainmin) then - tem1 = max(zero, (rain(i)-rainc(i))) * sr(i) - tem2 = one / rain(i) - if (t850(i) > 273.16_kind_phys) then - srflag(i) = max(zero, min(one, tem1*tem2)) - else - srflag(i) = max(zero, min(one, (tem1+rainc(i))*tem2)) - endif - else - srflag(i) = zero - rain(i) = zero - rainc(i) = zero - endif - tprcp(i) = max(zero, rain(i)) - enddo - else ! not GFDL or MG or Thompson microphysics - do i = 1, im - tprcp(i) = max(zero, rain(i)) - srflag(i) = sr(i) - enddo - endif - endif - - if (lssav) then -! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & -! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & -! 'rain=',Diag%rain(1) - do i=1,im - cnvprcp (i) = cnvprcp (i) + rainc(i) - totprcp (i) = totprcp (i) + rain(i) - totice (i) = totice (i) + ice(i) - totsnw (i) = totsnw (i) + snow(i) - totgrp (i) = totgrp (i) + graupel(i) - - cnvprcpb(i) = cnvprcpb(i) + rainc(i) - totprcpb(i) = totprcpb(i) + rain(i) - toticeb (i) = toticeb (i) + ice(i) - totsnwb (i) = totsnwb (i) + snow(i) - totgrpb (i) = totgrpb (i) + graupel(i) - enddo - - if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain - enddo - enddo - if (qdiag3d) then - do k=1,levs - do i=1,im - dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain - enddo - enddo - endif - endif - endif - - if (cplflx .or. cplchm) then - do i = 1, im - dsnow_cpl(i)= max(zero, rain(i) * srflag(i)) - drain_cpl(i)= max(zero, rain(i) - dsnow_cpl(i)) - rain_cpl(i) = rain_cpl(i) + drain_cpl(i) - snow_cpl(i) = snow_cpl(i) + dsnow_cpl(i) - enddo - endif - - if (cplchm) then - do i = 1, im - rainc_cpl(i) = rainc_cpl(i) + rainc(i) - enddo - endif - - pwat(:) = zero - do k = 1, levs - do i=1, im - work1(i) = zero - enddo - if (ncld > 0) then - do ic = ntcw, ntcw+nncl-1 - do i=1,im - work1(i) = work1(i) + gq0(i,k,ic) - enddo - enddo - endif - do i=1,im - pwat(i) = pwat(i) + del(i,k)*(gq0(i,k,1)+work1(i)) - enddo - enddo - do i=1,im - pwat(i) = pwat(i) * onebg - enddo - - if (lprnt) then - write(0,*)' end mp gt0=',gt0(ipr,:),' kdt=',kdt - write(0,*)' end mp gq0=',gq0(ipr,:,1),' kdt=',kdt - endif - - - end subroutine GFS_MP_generic_post_run -!> @} - - subroutine GFS_MP_generic_post_finalize() - end subroutine GFS_MP_generic_post_finalize - - end module GFS_MP_generic_post diff --git a/physics/debug/GFS_MP_generic.meta_dbg b/physics/debug/GFS_MP_generic.meta_dbg deleted file mode 100644 index dee5cb074..000000000 --- a/physics/debug/GFS_MP_generic.meta_dbg +++ /dev/null @@ -1,905 +0,0 @@ -[ccpp-table-properties] - name = GFS_MP_generic_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ldiag3d] - standard_name = flag_diagnostics_3D - long_name = logical flag for 3D diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[qdiag3d] - standard_name = flag_tracer_diagnostics_3D - long_name = logical flag for 3D tracer diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_aw] - standard_name = flag_for_Arakawa_Wu_adjustment - long_name = flag for Arakawa Wu scale-aware adjustment - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in - optional = F -[nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[gt0] - standard_name = air_temperature_updated_by_physics - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[save_qv] - standard_name = water_vapor_specific_humidity_save - long_name = water vapor specific humidity before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[save_q] - standard_name = tracer_concentration_save - long_name = tracer concentration before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_MP_generic_post - type = scheme - dependencies = calpreciptype.f90,machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current time step index - units = index - dimensions = () - type = integer - intent = in - optional = F -[nrcm] - standard_name = array_dimension_of_random_number - long_name = second dimension of random number stream for RAS - units = count - dimensions = () - type = integer - intent = in - optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F -[nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[imp_physics] - standard_name = flag_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_gfdl] - standard_name = flag_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_thompson] - standard_name = flag_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_mg] - standard_name = flag_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_fer_hires] - standard_name = flag_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[cal_pre] - standard_name = flag_for_precipitation_type_algorithm - long_name = flag controls precip type algorithm - units = flag - dimensions = () - type = logical - intent = in - optional = F -[lssav] - standard_name = flag_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ldiag3d] - standard_name = flag_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in - optional = F -[qdiag3d] - standard_name = flag_tracer_diagnostics_3D - long_name = logical flag for 3D tracer diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[dtf] - standard_name = time_step_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[frain] - standard_name = dynamics_to_physics_timestep_ratio - long_name = ratio of dynamics timestep to physics timestep - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rainc] - standard_name = lwe_thickness_of_convective_precipitation_amount_on_dynamics_timestep - long_name = convective rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rain1] - standard_name = lwe_thickness_of_explicit_precipitation_amount - long_name = explicit rainfall amount on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rann] - standard_name = random_number_array - long_name = random number array (0-1) - units = none - dimensions = (horizontal_loop_extent,array_dimension_of_random_number) - type = real - kind = kind_phys - intent = in - optional = F -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gt0] - standard_name = air_temperature_updated_by_physics - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = layer mean pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prsi] - standard_name = air_pressure_at_interface - long_name = pressure at layer interface - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[phii] - standard_name = geopotential_at_interface - long_name = geopotential at model layer interfaces - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ice] - standard_name = lwe_thickness_of_ice_amount_on_dynamics_timestep - long_name = ice fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snow] - standard_name = lwe_thickness_of_snow_amount_on_dynamics_timestep - long_name = snow fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[graupel] - standard_name = lwe_thickness_of_graupel_amount_on_dynamics_timestep - long_name = graupel fall at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[save_t] - standard_name = air_temperature_save - long_name = air temperature before entering a physics scheme - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[save_qv] - standard_name = water_vapor_specific_humidity_save - long_name = water vapor specific humidity before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[rain0] - standard_name = lwe_thickness_of_explicit_rain_amount - long_name = explicit rain on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ice0] - standard_name = lwe_thickness_of_ice_amount - long_name = ice fall on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snow0] - standard_name = lwe_thickness_of_snow_amount - long_name = snow fall on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[graupel0] - standard_name = lwe_thickness_of_graupel_amount - long_name = graupel fall on physics timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[del] - standard_name = air_pressure_difference_between_midlayers - long_name = air pressure difference between midlayers - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[rain] - standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total rain at this time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[domr_diag] - standard_name = dominant_rain_type - long_name = dominant rain type - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[domzr_diag] - standard_name = dominant_freezing_rain_type - long_name = dominant freezing rain type - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[domip_diag] - standard_name = dominant_sleet_type - long_name = dominant sleet type - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[doms_diag] - standard_name = dominant_snow_type - long_name = dominant snow type - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total precipitation amount in each time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[srflag] - standard_name = flag_for_precipitation_type - long_name = snow/rain flag for precipitation - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[sr] - standard_name = ratio_of_snowfall_to_rainfall - long_name = snow ratio: ratio of snow to total precipitation - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cnvprcp] - standard_name = cumulative_lwe_thickness_of_convective_precipitation_amount - long_name = cumulative convective precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totprcp] - standard_name = accumulated_lwe_thickness_of_precipitation_amount - long_name = accumulated total precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totice] - standard_name = accumulated_lwe_thickness_of_ice_amount - long_name = accumulated ice precipitation - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totsnw] - standard_name = accumulated_lwe_thickness_of_snow_amount - long_name = accumulated snow precipitation - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totgrp] - standard_name = accumulated_lwe_thickness_of_graupel_amount - long_name = accumulated graupel precipitation - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cnvprcpb] - standard_name = cumulative_lwe_thickness_of_convective_precipitation_amount_in_bucket - long_name = cumulative convective precipitation in bucket - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totprcpb] - standard_name = accumulated_lwe_thickness_of_precipitation_amount_in_bucket - long_name = accumulated total precipitation in bucket - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[toticeb] - standard_name = accumulated_lwe_thickness_of_ice_amount_in_bucket - long_name = accumulated ice precipitation in bucket - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totsnwb] - standard_name = accumulated_lwe_thickness_of_snow_amount_in_bucket - long_name = accumulated snow precipitation in bucket - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[totgrpb] - standard_name = accumulated_lwe_thickness_of_graupel_amount_in_bucket - long_name = accumulated graupel precipitation in bucket - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt] - standard_name = cumulative_change_in_temperature_due_to_microphysics - long_name = cumulative change in temperature due to microphysics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dq3dt] - standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_microphysics - long_name = cumulative change in water vapor specific humidity due to microphysics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[rain_cpl] - standard_name = lwe_thickness_of_precipitation_amount_for_coupling - long_name = total rain precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rainc_cpl] - standard_name = lwe_thickness_of_convective_precipitation_amount_for_coupling - long_name = total convective precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snow_cpl] - standard_name = lwe_thickness_of_snow_amount_for_coupling - long_name = total snow precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[pwat] - standard_name = column_precipitable_water - long_name = precipitable water - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[drain_cpl] - standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling - long_name = change in rain_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dsnow_cpl] - standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling - long_name = change in show_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_ruc] - standard_name = flag_for_ruc_land_surface_scheme - long_name = flag for RUC land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[raincprv] - standard_name = lwe_thickness_of_convective_precipitation_amount_from_previous_timestep - long_name = convective_precipitation_amount from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rainncprv] - standard_name = lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep - long_name = explicit rainfall from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[iceprv] - standard_name = lwe_thickness_of_ice_amount_from_previous_timestep - long_name = ice amount from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowprv] - standard_name = lwe_thickness_of_snow_amount_from_previous_timestep - long_name = snow amount from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[graupelprv] - standard_name = lwe_thickness_of_graupel_amount_from_previous_timestep - long_name = graupel amount from previous timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[draincprv] - standard_name = convective_precipitation_rate_from_previous_timestep - long_name = convective precipitation rate from previous timestep - units = mm s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[drainncprv] - standard_name = explicit_rainfall_rate_from_previous_timestep - long_name = explicit rainfall rate previous timestep - units = mm s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[diceprv] - standard_name = ice_precipitation_rate_from_previous_timestep - long_name = ice precipitation rate from previous timestep - units = mm s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dsnowprv] - standard_name = snow_precipitation_rate_from_previous_timestep - long_name = snow precipitation rate from previous timestep - units = mm s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dgraupelprv] - standard_name = graupel_precipitation_rate_from_previous_timestep - long_name = graupel precipitation rate from previous timestep - units = mm s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dtp] - standard_name = time_step_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - diff --git a/physics/debug/GFS_suite_interstitial.F90_dbg b/physics/debug/GFS_suite_interstitial.F90_dbg deleted file mode 100644 index ecca10133..000000000 --- a/physics/debug/GFS_suite_interstitial.F90_dbg +++ /dev/null @@ -1,850 +0,0 @@ -!> \file GFS_suite_interstitial.f90 -!! Contains code related to more than one scheme in the GFS physics suite. - - module GFS_suite_interstitial_rad_reset - - contains - - subroutine GFS_suite_interstitial_rad_reset_init () - end subroutine GFS_suite_interstitial_rad_reset_init - - subroutine GFS_suite_interstitial_rad_reset_finalize() - end subroutine GFS_suite_interstitial_rad_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_rad_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_rad_reset_run.html -!! - subroutine GFS_suite_interstitial_rad_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%rad_reset(Model) - - end subroutine GFS_suite_interstitial_rad_reset_run - - end module GFS_suite_interstitial_rad_reset - - - module GFS_suite_interstitial_phys_reset - - contains - - subroutine GFS_suite_interstitial_phys_reset_init () - end subroutine GFS_suite_interstitial_phys_reset_init - - subroutine GFS_suite_interstitial_phys_reset_finalize() - end subroutine GFS_suite_interstitial_phys_reset_finalize - -!> \section arg_table_GFS_suite_interstitial_phys_reset_run Argument Table -!! \htmlinclude GFS_suite_interstitial_phys_reset_run.html -!! - subroutine GFS_suite_interstitial_phys_reset_run (Interstitial, Model, errmsg, errflg) - - use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type, GFS_interstitial_type - - implicit none - - ! interface variables - type(GFS_interstitial_type), intent(inout) :: Interstitial - type(GFS_control_type), intent(in) :: Model - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - errmsg = '' - errflg = 0 - - call Interstitial%phys_reset(Model) - - end subroutine GFS_suite_interstitial_phys_reset_run - - end module GFS_suite_interstitial_phys_reset - - - module GFS_suite_interstitial_1 - - contains - - subroutine GFS_suite_interstitial_1_init () - end subroutine GFS_suite_interstitial_1_init - - subroutine GFS_suite_interstitial_1_finalize() - end subroutine GFS_suite_interstitial_1_finalize - -!> \section arg_table_GFS_suite_interstitial_1_run Argument Table -!! \htmlinclude GFS_suite_interstitial_1_run.html -!! - subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, dxmin, dxinv, pgr, & - islmsk, work1, work2, psurf, dudt, dvdt, dtdt, dqdt, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in) :: im, levs, ntrac - real(kind=kind_phys), intent(in) :: dtf, dtp, dxmin, dxinv - real(kind=kind_phys), intent(in), dimension(im) :: slmsk, area, pgr - - integer, intent(out), dimension(im) :: islmsk - real(kind=kind_phys), intent(out), dimension(im) :: work1, work2, psurf - real(kind=kind_phys), intent(out), dimension(im,levs) :: dudt, dvdt, dtdt - real(kind=kind_phys), intent(out), dimension(im,levs,ntrac) :: dqdt - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i, k, n - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i = 1, im - islmsk(i) = nint(slmsk(i)) - - work1(i) = (log(area(i)) - dxmin) * dxinv - work1(i) = max(zero, min(one, work1(i))) - work2(i) = one - work1(i) - psurf(i) = pgr(i) - end do - - do k=1,levs - do i=1,im - dudt(i,k) = zero - dvdt(i,k) = zero - dtdt(i,k) = zero - enddo - enddo - do n=1,ntrac - do k=1,levs - do i=1,im - dqdt(i,k,n) = zero - enddo - enddo - enddo - - end subroutine GFS_suite_interstitial_1_run - - end module GFS_suite_interstitial_1 - - - module GFS_suite_interstitial_2 - - use machine, only: kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - logical :: linit_mod = .false. - - contains - - subroutine GFS_suite_interstitial_2_init () - end subroutine GFS_suite_interstitial_2_init - - subroutine GFS_suite_interstitial_2_finalize() - end subroutine GFS_suite_interstitial_2_finalize -#if 0 -!> \section arg_table_GFS_suite_interstitial_2_run Argument Table -!! \htmlinclude GFS_suite_interstitial_2_run.html -!! -#endif - subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplflx, flag_cice, shal_cnv, old_monin, mstrat, & - do_shoc, frac_grid, imfshalcnv, dtf, xcosz, adjsfcdsw, adjsfcdlw, cice, pgr, ulwsfc_cice, lwhd, htrsw, htrlw, xmu, ctei_rm, & - work1, work2, prsi, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, cp, hvap, prslk, suntim, adjsfculw, adjsfculw_lnd, & - adjsfculw_ice, adjsfculw_wat, dlwsfc, ulwsfc, psmean, dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp, & - ctei_rml, ctei_r, kinver, dry, icy, wet, frland, huge, use_LW_jacobian, lprnt, ipr, kdt, errmsg, errflg) - - implicit none - - ! interface variables - integer, intent(in ) :: im, levs, imfshalcnv, ipr, kdt - logical, intent(in ) :: lssav, ldiag3d, lsidea, cplflx, shal_cnv, lprnt - logical, intent(in ) :: old_monin, mstrat, do_shoc, frac_grid, use_LW_jacobian - real(kind=kind_phys), intent(in ) :: dtf, cp, hvap - - logical, intent(in ), dimension(im) :: flag_cice - real(kind=kind_phys), intent(in ), dimension(2) :: ctei_rm - real(kind=kind_phys), intent(in ), dimension(im) :: xcosz, adjsfcdsw, adjsfcdlw, pgr, xmu, ulwsfc_cice, work1, work2 - real(kind=kind_phys), intent(in ), dimension(im) :: cice - real(kind=kind_phys), intent(in ), dimension(im, levs) :: htrsw, htrlw, tgrs, prsl, qgrs_water_vapor, qgrs_cloud_water, prslk - real(kind=kind_phys), intent(in ), dimension(im, levs+1) :: prsi - real(kind=kind_phys), intent(in ), dimension(im, levs, 6) :: lwhd - integer, intent(inout), dimension(im) :: kinver - real(kind=kind_phys), intent(inout), dimension(im) :: suntim, dlwsfc, ulwsfc, psmean, ctei_rml, ctei_r - real(kind=kind_phys), intent(in ), dimension(im) :: adjsfculw_lnd, adjsfculw_ice, adjsfculw_wat - real(kind=kind_phys), intent(inout), dimension(im) :: adjsfculw - - ! These arrays are only allocated if ldiag3d is .true. - real(kind=kind_phys), intent(inout), dimension(:,:) :: dt3dt_lw, dt3dt_sw, dt3dt_pbl, dt3dt_dcnv, dt3dt_scnv, dt3dt_mp - - logical, intent(in ), dimension(im) :: dry, icy, wet - real(kind=kind_phys), intent(in ), dimension(im) :: frland - real(kind=kind_phys), intent(in ) :: huge - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) - integer :: i, k - real(kind=kind_phys) :: tem1, tem2, tem, hocp - logical, dimension(im) :: invrsn - real(kind=kind_phys), dimension(im) :: tx1, tx2 - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - hocp = hvap/cp - - if (lprnt) then - write(0,*)' tgrs=',tgrs(ipr,:),' kdt=',kdt - write(0,*)' qgrs=',qgrs_water_vapor(ipr,:),' kdt=',kdt - endif - - if (lssav) then ! --- ... accumulate/save output variables - -! --- ... sunshine duration time is defined as the length of time (in mdl output -! interval) that solar radiation falling on a plane perpendicular to the -! direction of the sun >= 120 w/m2 - - do i = 1, im - if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg - tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0_kind_phys ) then - suntim(i) = suntim(i) + dtf - endif - endif - enddo - -! --- ... sfc lw fluxes used by atmospheric model are saved for output - if (.not. use_LW_jacobian) then - if (frac_grid) then - do i=1,im - tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - endif - enddo - else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) - elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif - else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = adjsfculw_ice(i) - endif - endif - else ! all water - adjsfculw(i) = adjsfculw_wat(i) - endif - enddo - endif - endif - - do i=1,im - dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf - ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf - psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - enddo - - if (ldiag3d) then - if (lsidea) then - do k=1,levs - do i=1,im - dt3dt_lw(i,k) = dt3dt_lw(i,k) + lwhd(i,k,1)*dtf - dt3dt_sw(i,k) = dt3dt_sw(i,k) + lwhd(i,k,2)*dtf - dt3dt_pbl(i,k) = dt3dt_pbl(i,k) + lwhd(i,k,3)*dtf - dt3dt_dcnv(i,k) = dt3dt_dcnv(i,k) + lwhd(i,k,4)*dtf - dt3dt_scnv(i,k) = dt3dt_scnv(i,k) + lwhd(i,k,5)*dtf - dt3dt_mp(i,k) = dt3dt_mp(i,k) + lwhd(i,k,6)*dtf - enddo - enddo - else - do k=1,levs - do i=1,im - dt3dt_lw(i,k) = dt3dt_lw(i,k) + htrlw(i,k)*dtf - dt3dt_sw(i,k) = dt3dt_sw(i,k) + htrsw(i,k)*dtf*xmu(i) - enddo - enddo - endif - endif - endif ! end if_lssav_block - - do i=1, im - invrsn(i) = .false. - tx1(i) = zero - tx2(i) = 10.0_kind_phys - ctei_r(i) = 10.0_kind_phys - enddo - - if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & - .or. do_shoc) then - ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) - do k=1,levs/2 - do i=1,im - if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & - .and. (.not. invrsn(i))) then - tem = (tgrs(i,k+1) - tgrs(i,k)) & - / (prsl(i,k) - prsl(i,k+1)) - - if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & - ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then - invrsn(i) = .true. - - if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then - tem1 = tgrs(i,k+1) + hocp*max(qgrs_water_vapor(i,k+1),qmin) - tem2 = tgrs(i,k) + hocp*max(qgrs_water_vapor(i,k),qmin) - - tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) - -! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & - + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) - else - ctei_r(i) = 10.0_kind_phys - endif - - if ( ctei_rml(i) > ctei_r(i) ) then - kinver(i) = k - else - kinver(i) = levs - endif - endif - - tx2(i) = tx1(i) - tx1(i) = tem - endif - enddo - enddo - endif - - end subroutine GFS_suite_interstitial_2_run - - end module GFS_suite_interstitial_2 - - - module GFS_suite_stateout_reset - - contains - - subroutine GFS_suite_stateout_reset_init () - end subroutine GFS_suite_stateout_reset_init - - subroutine GFS_suite_stateout_reset_finalize() - end subroutine GFS_suite_stateout_reset_finalize - -!> \section arg_table_GFS_suite_stateout_reset_run Argument Table -!! \htmlinclude GFS_suite_stateout_reset_run.html -!! - subroutine GFS_suite_stateout_reset_run (im, levs, ntrac, & - tgrs, ugrs, vgrs, qgrs, & - gt0 , gu0 , gv0 , gq0 , & - errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in) :: im - integer, intent(in) :: levs - integer, intent(in) :: ntrac - real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs, ugrs, vgrs - real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: qgrs - real(kind=kind_phys), dimension(im,levs), intent(out) :: gt0, gu0, gv0 - real(kind=kind_phys), dimension(im,levs,ntrac), intent(out) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) - gu0(:,:) = ugrs(:,:) - gv0(:,:) = vgrs(:,:) - gq0(:,:,:) = qgrs(:,:,:) - - end subroutine GFS_suite_stateout_reset_run - - end module GFS_suite_stateout_reset - - - module GFS_suite_stateout_update - - contains - - subroutine GFS_suite_stateout_update_init () - end subroutine GFS_suite_stateout_update_init - - subroutine GFS_suite_stateout_update_finalize() - end subroutine GFS_suite_stateout_update_finalize - -!> \section arg_table_GFS_suite_stateout_update_run Argument Table -!! \htmlinclude GFS_suite_stateout_update_run.html -!! - subroutine GFS_suite_stateout_update_run (im, levs, ntrac, dtp, & - tgrs, ugrs, vgrs, qgrs, dudt, dvdt, dtdt, dqdt, & - gt0, gu0, gv0, gq0, ntiw, nqrimef, imp_physics, & - imp_physics_fer_hires, epsq, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in) :: im - integer, intent(in) :: levs - integer, intent(in) :: ntrac - integer, intent(in) :: imp_physics,imp_physics_fer_hires - integer, intent(in) :: ntiw, nqrimef - real(kind=kind_phys), intent(in) :: dtp, epsq - - real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs, ugrs, vgrs - real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: qgrs - real(kind=kind_phys), dimension(im,levs), intent(in) :: dudt, dvdt, dtdt - real(kind=kind_phys), dimension(im,levs,ntrac), intent(in) :: dqdt - real(kind=kind_phys), dimension(im,levs), intent(out) :: gt0, gu0, gv0 - real(kind=kind_phys), dimension(im,levs,ntrac), intent(out) :: gq0 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: i, k - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - gt0(:,:) = tgrs(:,:) + dtdt(:,:) * dtp - gu0(:,:) = ugrs(:,:) + dudt(:,:) * dtp - gv0(:,:) = vgrs(:,:) + dvdt(:,:) * dtp - gq0(:,:,:) = qgrs(:,:,:) + dqdt(:,:,:) * dtp - - if (imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - if(gq0(i,k,ntiw) > epsq) then - gq0(i,k,nqrimef) = max(1., gq0(i,k,nqrimef)/gq0(i,k,ntiw)) - else - gq0(i,k,nqrimef) = 1. - end if - end do - end do - end if - - end subroutine GFS_suite_stateout_update_run - - end module GFS_suite_stateout_update - - - module GFS_suite_interstitial_3 - - contains - - subroutine GFS_suite_interstitial_3_init () - end subroutine GFS_suite_interstitial_3_init - - subroutine GFS_suite_interstitial_3_finalize() - end subroutine GFS_suite_interstitial_3_finalize - -#if 0 -!> \section arg_table_GFS_suite_interstitial_3_run Argument Table -!! \htmlinclude GFS_suite_interstitial_3_run.html -!! -#endif - subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & - satmedmf, trans_trac, do_shoc, ltaerosol, ntrac, ntcw, & - ntiw, ntclamt, ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, & - xlon, xlat, gt0, gq0, imp_physics, imp_physics_mg, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, & - imp_physics_wsm6, imp_physics_fer_hires, prsi, & - prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & - work1, work2, kpbl, kinver, ras, me, & - clw, rhc, save_qc, save_qi, save_tcp, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & - imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, me - integer, dimension(im), intent(in) :: islmsk, kpbl, kinver - logical, intent(in) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras - - real(kind=kind_phys), intent(in) :: rhcbot, rhcmax, rhcpbl, rhctop - real(kind=kind_phys), dimension(im), intent(in) :: work1, work2 - real(kind=kind_phys), dimension(im, levs), intent(in) :: prsl, prslk - real(kind=kind_phys), dimension(im, levs+1), intent(in) :: prsi - real(kind=kind_phys), dimension(im), intent(in) :: xlon, xlat - real(kind=kind_phys), dimension(im, levs), intent(in) :: gt0 - real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 - - real(kind=kind_phys), dimension(im, levs), intent(inout) :: rhc, save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), dimension(:, :), intent(inout) :: save_qi - real(kind=kind_phys), dimension(:, :), intent(inout) :: save_tcp ! ONLY ALLOCATE FOR THOMPSON! TODO - real(kind=kind_phys), dimension(im, levs, nn), intent(inout) :: clw - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i,k,n,tracers,kk - real(kind=kind_phys) :: tem, tem1, tem2 - real(kind=kind_phys), dimension(im) :: tx1, tx2, tx3, tx4 - - !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & - ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 - ! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (cscnv .or. satmedmf .or. trans_trac .or. ras) then - tracers = 2 - do n=2,ntrac - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc) then - tracers = tracers + 1 - do k=1,levs - do i=1,im - clw(i,k,tracers) = gq0(i,k,n) - enddo - enddo - endif - enddo - endif ! end if_ras or cfscnv or samf - - if (ntcw > 0) then - if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf - do i=1,im - tx1(i) = one / prsi(i,1) - tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) - - kk = min(kinver(i), max(2,kpbl(i))) - tx3(i) = prsi(i,kk)*tx1(i) - tx4(i) = rhcpbl - rhctop*abs(cos(xlat(i))) - enddo - do k = 1, levs - do i = 1, im - tem = prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) - ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 - ! and rhcbot represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning - if (islmsk(i) > 0) then - tem1 = one / (one+exp(tem1+tem1)) - else - tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) - endif - tem2 = one / (one+exp(tem2)) - - rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) - enddo - enddo - else - do k=1,levs - do i=1,im - kk = max(10,kpbl(i)) - if (k < kk) then - tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) - else - tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) - endif - tem = rhcmax * work1(i) + tem * work2(i) - rhc(i,k) = max(zero, min(one,tem)) - enddo - enddo - endif - else - rhc(:,:) = 1.0 - endif - - if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_zhao_carr_pdf) then ! zhao-carr microphysics - !GF* move to GFS_MP_generic_pre (from gscond/precpd) - ! do i=1,im - ! psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) - ! prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) - ! enddo - !*GF - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntcw) - enddo - enddo - elseif (imp_physics == imp_physics_gfdl) then - clw(1:im,:,1) = gq0(1:im,:,ntcw) - elseif (imp_physics == imp_physics_thompson) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - save_tcp(i,k) = gt0(i,k) - enddo - enddo - if(ltaerosol) then - save_qi(:,:) = clw(:,:,1) - save_qc(:,:) = clw(:,:,2) - else - save_qi(:,:) = clw(:,:,1) - endif - elseif (imp_physics == imp_physics_wsm6 .or. imp_physics == imp_physics_mg .or. imp_physics == imp_physics_fer_hires) then - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - endif - - end subroutine GFS_suite_interstitial_3_run - - end module GFS_suite_interstitial_3 - - module GFS_suite_interstitial_4 - - contains - - subroutine GFS_suite_interstitial_4_init () - end subroutine GFS_suite_interstitial_4_init - - subroutine GFS_suite_interstitial_4_finalize() - end subroutine GFS_suite_interstitial_4_finalize - -!> \section arg_table_GFS_suite_interstitial_4_run Argument Table -!! \htmlinclude GFS_suite_interstitial_4_run.html -!! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & - ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, dtf, save_qc, save_qi, con_pi, & - gq0, clw, prsl, save_tcp, con_rd, nwfa, spechum, dqdti, errmsg, errflg) - - use machine, only: kind_phys - use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber - - implicit none - - ! interface variables - - integer, intent(in) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & - ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - - logical, intent(in) :: ltaerosol, cplchm - - real(kind=kind_phys), intent(in) :: con_pi, dtf - real(kind=kind_phys), dimension(im,levs), intent(in) :: save_qc - ! save_qi is not allocated for Zhao-Carr MP - real(kind=kind_phys), dimension(:, :), intent(in) :: save_qi - - real(kind=kind_phys), dimension(im,levs,ntrac), intent(inout) :: gq0 - real(kind=kind_phys), dimension(im,levs,nn), intent(inout) :: clw - real(kind=kind_phys), dimension(im,levs), intent(in) :: prsl - real(kind=kind_phys), intent(in) :: con_rd - real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp - real(kind=kind_phys), dimension(im,levs), intent(in) :: spechum - - ! dqdti may not be allocated - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i,k,n,tracers - - real(kind=kind_phys), dimension(im,levs) :: rho_dryair - real(kind=kind_phys), dimension(im,levs) :: qv_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qc_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: qi_mp !< kg kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: nc_mp !< kg-1 (dry mixing ratio) - real(kind=kind_phys), dimension(im,levs) :: ni_mp !< kg-1 (dry mixing ratio) - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! --- update the tracers due to deep & shallow cumulus convective transport -! (except for suspended water and ice) - - if (tracers_total > 0) then - tracers = 2 - do n=2,ntrac -! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then - if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & - n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & - n /= ntsnc .and. n /= ntgl .and. n /= ntgnc ) then - tracers = tracers + 1 - do k=1,levs - do i=1,im - gq0(i,k,n) = clw(i,k,tracers) - enddo - enddo - endif - enddo - endif - - if (ntcw > 0) then - -! for microphysics - if (imp_physics == imp_physics_zhao_carr .or. & - imp_physics == imp_physics_zhao_carr_pdf .or. & - imp_physics == imp_physics_gfdl) then - gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) - - elseif (ntiw > 0) then - do k=1,levs - do i=1,im - gq0(i,k,ntiw) = clw(i,k,1) ! ice - gq0(i,k,ntcw) = clw(i,k,2) ! water - enddo - enddo - - if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then - do k=1,levs - do i=1,im - !> - Density of air in kg m-3 - rho_dryair(i,k) = prsl(i,k) / (con_rd*save_tcp(i,k)) - !> - Convert specific humidity to dry mixing ratio - qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) - if (ntlnc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho_dryair(i,k), nwfa(i,k)) * (one/rho_dryair(i,k))) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) - endif - if (ntinc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) - !> - Convert number concentration from moist to dry - ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho_dryair(i,k), save_tcp(i,k)) * (one/rho_dryair(i,k))) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) - endif - enddo - enddo - endif - - else - do k=1,levs - do i=1,im - gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntiw - - else - do k=1,levs - do i=1,im - clw(i,k,1) = clw(i,k,1) + clw(i,k,2) - enddo - enddo - endif ! end if_ntcw - -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (cplchm) then - do k=1,levs - do i=1,im - dqdti(i,k) = dqdti(i,k) * (one / dtf) - enddo - enddo - endif - - end subroutine GFS_suite_interstitial_4_run - - end module GFS_suite_interstitial_4 - - module GFS_suite_interstitial_5 - - contains - - subroutine GFS_suite_interstitial_5_init () - end subroutine GFS_suite_interstitial_5_init - - subroutine GFS_suite_interstitial_5_finalize() - end subroutine GFS_suite_interstitial_5_finalize - -!> \section arg_table_GFS_suite_interstitial_5_run Argument Table -!! \htmlinclude GFS_suite_interstitial_5_run.html -!! - subroutine GFS_suite_interstitial_5_run (im, levs, ntrac, ntcw, ntiw, nn, gq0, clw, errmsg, errflg) - - use machine, only: kind_phys - - implicit none - - ! interface variables - integer, intent(in) :: im, levs, ntrac, ntcw, ntiw, nn - - real(kind=kind_phys), dimension(im, levs, ntrac), intent(in) :: gq0 - - real(kind=kind_phys), dimension(im, levs, nn), intent(out) :: clw - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! local variables - integer :: i,k - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do k=1,levs - do i=1,im - clw(i,k,1) = gq0(i,k,ntiw) ! ice - clw(i,k,2) = gq0(i,k,ntcw) ! water - enddo - enddo - - end subroutine GFS_suite_interstitial_5_run - - end module GFS_suite_interstitial_5 - diff --git a/physics/debug/GFS_suite_interstitial.meta_dbg b/physics/debug/GFS_suite_interstitial.meta_dbg deleted file mode 100644 index 85d5fe1c8..000000000 --- a/physics/debug/GFS_suite_interstitial.meta_dbg +++ /dev/null @@ -1,2014 +0,0 @@ -[ccpp-table-properties] - name = GFS_suite_interstitial_rad_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_rad_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout - optional = F -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_phys_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_phys_reset_run - type = scheme -[Interstitial] - standard_name = GFS_interstitial_type_instance - long_name = derived type GFS_interstitial_type in FV3 - units = DDT - dimensions = () - type = GFS_interstitial_type - intent = inout - optional = F -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT - dimensions = () - type = GFS_control_type - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_1 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_1_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[dtf] - standard_name = time_step_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[dtp] - standard_name = time_step_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[slmsk] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[area] - standard_name = cell_area - long_name = area of the grid cell - units = m2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[dxmin] - standard_name = minimum_scaling_factor_for_critical_relative_humidity - long_name = minimum scaling factor for critical relative humidity - units = m2 rad-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[dxinv] - standard_name = inverse_scaling_factor_for_critical_relative_humidity - long_name = inverse scaling factor for critical relative humidity - units = rad2 m-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out - optional = F -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[psurf] - standard_name = surface_air_pressure_diag - long_name = surface air pressure diagnostic - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dudt] - standard_name = tendency_of_x_wind_due_to_model_physics - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dvdt] - standard_name = tendency_of_y_wind_due_to_model_physics - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dtdt] - standard_name = tendency_of_air_temperature_due_to_model_physics - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[dqdt] - standard_name = tendency_of_tracers_due_to_model_physics - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_2 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_2_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[lssav] - standard_name = flag_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ldiag3d] - standard_name = flag_diagnostics_3D - long_name = flag for 3d diagnostic fields - units = flag - dimensions = () - type = logical - intent = in - optional = F -[lsidea] - standard_name = flag_idealized_physics - long_name = flag for idealized physics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[shal_cnv] - standard_name = flag_for_shallow_convection - long_name = flag for calling shallow convection - units = flag - dimensions = () - type = logical - intent = in - optional = F -[old_monin] - standard_name = flag_for_old_PBL_scheme - long_name = flag for using old PBL schemes - units = flag - dimensions = () - type = logical - intent = in - optional = F -[mstrat] - standard_name = flag_for_moorthi_stratus - long_name = flag for moorthi approach for stratus - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in - optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[imfshalcnv] - standard_name = flag_for_mass_flux_shallow_convection_scheme - long_name = flag for mass-flux shallow convection scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[dtf] - standard_name = time_step_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[xcosz] - standard_name = instantaneous_cosine_of_zenith_angle - long_name = cosine of zenith angle at current time - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ulwsfc_cice] - standard_name = surface_upwelling_longwave_flux_for_coupling - long_name = surface upwelling longwave flux for coupling - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lwhd] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_for_idea - long_name = idea sky lw heating rates - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension,6) - type = real - kind = kind_phys - intent = in - optional = F -[htrsw] - standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_time_step - long_name = total sky sw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[htrlw] - standard_name = tendency_of_air_temperature_due_to_longwave_heating_on_radiation_time_step - long_name = total sky lw heating rate - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[xmu] - standard_name = zenith_angle_temporal_adjustment_factor_for_shortwave_fluxes - long_name = zenith angle temporal adjustment factor for shortwave fluxes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ctei_rm] - standard_name = critical_cloud_top_entrainment_instability_criteria - long_name = critical cloud top entrainment instability criteria - units = none - dimensions = (2) - type = real - kind = kind_phys - intent = in - optional = F -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[qgrs_water_vapor] - standard_name = water_vapor_specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[qgrs_cloud_water] - standard_name = cloud_condensed_water_mixing_ratio - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[prslk] - standard_name = dimensionless_exner_function_at_model_layers - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[suntim] - standard_name = duration_of_sunshine - long_name = sunshine duration time - units = s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[use_LW_jacobian] - standard_name = flag_to_calc_RRTMGP_LW_jacobian - long_name = logical flag to control RRTMGP LW calculation - units = flag - dimensions = () - type = logical - intent = in - optional = F -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[adjsfculw_lnd] - standard_name = surface_upwelling_longwave_flux_over_land_interstitial - long_name = surface upwelling longwave flux at current time over land (temporary use as interstitial) - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfculw_ice] - standard_name = surface_upwelling_longwave_flux_over_ice_interstitial - long_name = surface upwelling longwave flux at current time over ice (temporary use as interstitial) - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfculw_wat] - standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial - long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[dlwsfc] - standard_name = cumulative_surface_downwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface downwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ulwsfc] - standard_name = cumulative_surface_upwelling_longwave_flux_multiplied_by_timestep - long_name = cumulative surface upwelling LW flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[psmean] - standard_name = cumulative_surface_pressure_multiplied_by_timestep - long_name = cumulative surface pressure multiplied by timestep - units = Pa s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_lw] - standard_name = cumulative_change_in_temperature_due_to_longwave_radiation - long_name = cumulative change in temperature due to longwave radiation - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_sw] - standard_name = cumulative_change_in_temperature_due_to_shortwave_radiation - long_name = cumulative change in temperature due to shortwave radiation - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_pbl] - standard_name = cumulative_change_in_temperature_due_to_PBL - long_name = cumulative change in temperature due to PBL - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_dcnv] - standard_name = cumulative_change_in_temperature_due_to_deep_convection - long_name = cumulative change in temperature due to deep conv. - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_scnv] - standard_name = cumulative_change_in_temperature_due_to_shallow_convection - long_name = cumulative change in temperature due to shal conv. - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dt3dt_mp] - standard_name = cumulative_change_in_temperature_due_to_microphysics - long_name = cumulative change in temperature due to microphysics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[ctei_rml] - standard_name = grid_sensitive_critical_cloud_top_entrainment_instability_criteria - long_name = grid sensitive critical cloud top entrainment instability criteria - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ctei_r] - standard_name = cloud_top_entrainment_instability_value - long_name = cloud top entrainment instability value - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[huge] - standard_name = netcdf_float_fillvalue - long_name = definition of NetCDF float FillValue - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = inout - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = inout - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_stateout_reset - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_reset_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[gt0] - standard_name = air_temperature_updated_by_physics - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gu0] - standard_name = x_wind_updated_by_physics - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gv0] - standard_name = y_wind_updated_by_physics - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_stateout_update - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_stateout_update_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[dtp] - standard_name = time_step_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[dudt] - standard_name = tendency_of_x_wind_due_to_model_physics - long_name = updated tendency of the x wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[dvdt] - standard_name = tendency_of_y_wind_due_to_model_physics - long_name = updated tendency of the y wind - units = m s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[dtdt] - standard_name = tendency_of_air_temperature_due_to_model_physics - long_name = updated tendency of the temperature - units = K s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[dqdt] - standard_name = tendency_of_tracers_due_to_model_physics - long_name = updated tendency of the tracers - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[gt0] - standard_name = air_temperature_updated_by_physics - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gu0] - standard_name = x_wind_updated_by_physics - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gv0] - standard_name = y_wind_updated_by_physics - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = out - optional = F -[ntiw] - standard_name = index_for_ice_cloud_condensate - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in - optional = F -[nqrimef] - standard_name = index_for_mass_weighted_rime_factor - long_name = tracer index for mass weighted rime factor - units = index - dimensions = () - type = integer - intent = in - optional = F -[imp_physics] - standard_name = flag_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_fer_hires] - standard_name = flag_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[epsq] - standard_name = minimum_value_of_specific_humidity - long_name = floor value for specific humidity - units = kg kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_3 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_3_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in - optional = F -[cscnv] - standard_name = flag_for_Chikira_Sugiyama_deep_convection - long_name = flag for Chikira-Sugiyama convection - units = flag - dimensions = () - type = logical - intent = in - optional = F -[satmedmf] - standard_name = flag_for_scale_aware_TKE_moist_EDMF_PBL - long_name = flag for scale-aware TKE moist EDMF PBL scheme - units = flag - dimensions = () - type = logical - intent = in - optional = F -[trans_trac] - standard_name = flag_for_convective_transport_of_tracers - long_name = flag for convective transport of tracers - units = flag - dimensions = () - type = logical - intent = in - optional = F -[do_shoc] - standard_name = flag_for_shoc - long_name = flag for SHOC - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntiw] - standard_name = index_for_ice_cloud_condensate - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntclamt] - standard_name = index_for_cloud_amount - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntrw] - standard_name = index_for_rain_water - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntsw] - standard_name = index_for_snow_water - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntrnc] - standard_name = index_for_rain_number_concentration - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntsnc] - standard_name = index_for_snow_number_concentration - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntgl] - standard_name = index_for_graupel - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntgnc] - standard_name = index_for_graupel_number_concentration - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gt0] - standard_name = air_temperature_updated_by_physics - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[imp_physics] - standard_name = flag_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_mg] - standard_name = flag_for_morrison_gettelman_microphysics_scheme - long_name = choice of Morrison-Gettelman microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_zhao_carr] - standard_name = flag_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_zhao_carr_pdf] - standard_name = flag_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_gfdl] - standard_name = flag_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_thompson] - standard_name = flag_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_wsm6] - standard_name = flag_for_wsm6_microphysics_scheme - long_name = choice of WSM6 microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_fer_hires] - standard_name = flag_for_fer_hires_microphysics_scheme - long_name = choice of Ferrier-Aligo microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[prsi] - standard_name = air_pressure_at_interface - long_name = air pressure at model layer interfaces - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension_plus_one) - type = real - kind = kind_phys - intent = in - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[prslk] - standard_name = dimensionless_exner_function_at_model_layers - long_name = dimensionless Exner function at model layer centers - units = none - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[rhcbot] - standard_name = critical_relative_humidity_at_surface - long_name = critical relative humidity at the surface - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rhcpbl] - standard_name = critical_relative_humidity_at_PBL_top - long_name = critical relative humidity at the PBL top - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rhctop] - standard_name = critical_relative_humidity_at_top_of_atmosphere - long_name = critical relative humidity at the top of atmosphere - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rhcmax] - standard_name = maximum_critical_relative_humidity - long_name = maximum critical relative humidity - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[work1] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes - long_name = grid size related coefficient used in scale-sensitive schemes - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[work2] - standard_name = grid_size_related_coefficient_used_in_scale_sensitive_schemes_complement - long_name = complement to work1 - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[kpbl] - standard_name = vertical_index_at_top_of_atmosphere_boundary_layer - long_name = vertical index at top atmospheric boundary layer - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[kinver] - standard_name = index_of_highest_temperature_inversion - long_name = index of highest temperature inversion - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[ras] - standard_name = flag_for_ras_deep_convection - long_name = flag for ras convection scheme - units = flag - dimensions = () - type = logical - intent = in - optional = F -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout - optional = F -[rhc] - standard_name = critical_relative_humidity - long_name = critical relative humidity - units = frac - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_4 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_4_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ltaerosol] - standard_name = flag_for_aerosol_physics - long_name = flag for aerosol physics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[tracers_total] - standard_name = number_of_total_tracers - long_name = total number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntiw] - standard_name = index_for_ice_cloud_condensate - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntclamt] - standard_name = index_for_cloud_amount - long_name = tracer index for cloud amount integer - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntrw] - standard_name = index_for_rain_water - long_name = tracer index for rain water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntsw] - standard_name = index_for_snow_water - long_name = tracer index for snow water - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntrnc] - standard_name = index_for_rain_number_concentration - long_name = tracer index for rain number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntsnc] - standard_name = index_for_snow_number_concentration - long_name = tracer index for snow number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntgl] - standard_name = index_for_graupel - long_name = tracer index for graupel - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntgnc] - standard_name = index_for_graupel_number_concentration - long_name = tracer index for graupel number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntlnc] - standard_name = index_for_liquid_cloud_number_concentration - long_name = tracer index for liquid number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntinc] - standard_name = index_for_ice_cloud_number_concentration - long_name = tracer index for ice number concentration - units = index - dimensions = () - type = integer - intent = in - optional = F -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in - optional = F -[imp_physics] - standard_name = flag_for_microphysics_scheme - long_name = choice of microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_gfdl] - standard_name = flag_for_gfdl_microphysics_scheme - long_name = choice of GFDL microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_thompson] - standard_name = flag_for_thompson_microphysics_scheme - long_name = choice of Thompson microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_zhao_carr] - standard_name = flag_for_zhao_carr_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme - units = flag - dimensions = () - type = integer - intent = in - optional = F -[imp_physics_zhao_carr_pdf] - standard_name = flag_for_zhao_carr_pdf_microphysics_scheme - long_name = choice of Zhao-Carr microphysics scheme with PDF clouds - units = flag - dimensions = () - type = integer - intent = in - optional = F -[dtf] - standard_name = time_step_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[save_qc] - standard_name = cloud_condensed_water_mixing_ratio_save - long_name = ratio of mass of cloud water to mass of dry air plus vapor (without condensates) before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[save_qi] - standard_name = ice_water_mixing_ratio_save - long_name = cloud ice water mixing ratio before entering a physics scheme - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[con_pi] - standard_name = pi - long_name = ratio of a circle's circumference to its diameter - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = inout - optional = F -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout - optional = F -[prsl] - standard_name = air_pressure - long_name = mean layer pressure - units = Pa - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[save_tcp] - standard_name = air_temperature_save_from_convective_parameterization - long_name = air temperature after cumulus parameterization - units = K - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[con_rd] - standard_name = gas_constant_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[nwfa] - standard_name = water_friendly_aerosol_number_concentration - long_name = number concentration of water-friendly aerosols - units = kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[spechum] - standard_name = water_vapor_specific_humidity - long_name = water vapor specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_suite_interstitial_5 - type = scheme - dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_suite_interstitial_5_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntrac] - standard_name = number_of_tracers - long_name = number of tracers - units = count - dimensions = () - type = integer - intent = in - optional = F -[ntcw] - standard_name = index_for_liquid_cloud_condensate - long_name = tracer index for cloud condensate (or liquid water) - units = index - dimensions = () - type = integer - intent = in - optional = F -[ntiw] - standard_name = index_for_ice_cloud_condensate - long_name = tracer index for ice water - units = index - dimensions = () - type = integer - intent = in - optional = F -[nn] - standard_name = number_of_tracers_for_convective_transport - long_name = number of tracers for convective transport - units = count - dimensions = () - type = integer - intent = in - optional = F -[gq0] - standard_name = tracer_concentration_updated_by_physics - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in - optional = F -[clw] - standard_name = convective_transportable_tracers - long_name = array to contain cloud water and other convective trans. tracers - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_dimension,number_of_tracers_for_convective_transport) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/GFS_surface_composites.F90_dbg b/physics/debug/GFS_surface_composites.F90_dbg deleted file mode 100644 index cef075a1f..000000000 --- a/physics/debug/GFS_surface_composites.F90_dbg +++ /dev/null @@ -1,678 +0,0 @@ -!> \file GFS_surface_composites.F90 -!! Contains code related to generating composites for all GFS surface schemes. - -module GFS_surface_composites_pre - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys - - real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue - -contains - - subroutine GFS_surface_composites_pre_init () - end subroutine GFS_surface_composites_pre_init - - subroutine GFS_surface_composites_pre_finalize() - end subroutine GFS_surface_composites_pre_finalize - -!> \section arg_table_GFS_surface_composites_pre_run Argument Table -!! \htmlinclude GFS_surface_composites_pre_run.html -!! - subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, frland, dry, icy, use_flake, ocean, wet, & - hice, cice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & - weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & - tsfc_lnd, tsfc_ice, tisfc, tice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & - qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & - min_lakeice, min_seaice, zorlo, zorll, zorli, & - xlon, xlat, lprnt, ipr, kdt, & - errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im, lkm - integer, intent(inout) :: ipr, kdt - logical, intent(in ) :: frac_grid, cplflx, cplwav2atm - logical, intent(inout) :: lprnt - logical, dimension(im), intent(inout) :: flag_cice - logical, dimension(im), intent(inout) :: dry, icy, use_flake, ocean, wet - real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac - real(kind=kind_phys), dimension(im), intent(inout) :: cice, hice - real(kind=kind_phys), dimension(im), intent( out) :: frland - real(kind=kind_phys), dimension(im), intent(in ) :: snowd, tprcp, uustar, weasd, qss, hflx - real(kind=kind_phys), dimension(im), intent(in ) :: xlon, xlat - - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, tsfco, tsfcl, tisfc, tsurf - real(kind=kind_phys), dimension(im), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & - tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & - qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice - real(kind=kind_phys), dimension(im), intent( out) :: tice - real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(im), intent(inout) :: islmsk, islmsk_cice - real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad - real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice, slmsk - real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice - ! - real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli - ! - real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice - - real(kind=kind_phys), parameter :: degrad = 180.0/3.1415926 - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - lprnt = .false. - do i=1,im - lprnt = kdt > 0 .and. kdt < 25 .and. abs(xlon(i)*degrad-109.01) < 0.1 & - .and. abs(xlat(i)*degrad+66.35) < 0.1 - if (lprnt) then - ipr = i - write(0,*)' lprnt=',lprnt,' ipr=',ipr,' xlon_d=',xlon(i)*degrad,' xlat_d=',xlat(i)*degrad - exit - endif - enddo - - if (frac_grid) then ! cice is ice fraction wrt water area - do i=1,im - frland(i) = landfrac(i) - if (frland(i) > zero) dry(i) = .true. - if (frland(i) < one) then - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - if (cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk_cice(i) = 0 - islmsk(i) = 0 - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - else ! all land - cice(i) = zero - hice(i) = zero - islmsk_cice(i) = 1 - islmsk(i) = 1 - endif - enddo - - else - - do i = 1, IM - if (islmsk(i) == 1) then -! tsfcl(i) = tsfc(i) - dry(i) = .true. - frland(i) = one - cice(i) = zero - hice(i) = zero - else - frland(i) = zero - if (oceanfrac(i) > zero) then - if (cice(i) >= min_seaice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - if (cplflx) then - islmsk_cice(i) = 4 - flag_cice(i) = .true. - else - islmsk_cice(i) = 2 - flag_cice(i) = .false. - endif - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - flag_cice(i) = .false. - islmsk(i) = 0 - islmsk_cice(i) = 0 - endif - if (cice(i) < one) then - wet(i) = .true. ! some open ocean - if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - else - if (cice(i) >= min_lakeice) then - icy(i) = .true. - tisfc(i) = max(timin, min(tisfc(i), tgice)) - islmsk(i) = 2 - else - cice(i) = zero - hice(i) = zero - islmsk(i) = 0 - endif - islmsk_cice(i) = islmsk(i) - flag_cice(i) = .false. - if (cice(i) < one) then - wet(i) = .true. ! some open lake - if (icy(i)) tsfco(i) = max(tisfc(i), tgice) - endif - endif - endif - enddo - endif - - do i=1,im - tprcp_wat(i) = tprcp(i) - tprcp_lnd(i) = tprcp(i) - tprcp_ice(i) = tprcp(i) - if (wet(i)) then ! Water -! uustar_wat(i) = uustar(i) - tsfc_wat(i) = tsfco(i) - tsurf_wat(i) = tsfco(i) -! weasd_wat(i) = weasd(i) -! snowd_wat(i) = snowd(i) - weasd_wat(i) = zero - snowd_wat(i) = zero - semis_wat(i) = 0.97_kind_phys -! semis_wat(i) = 0.984_kind_phys -! qss_wat(i) = qss(i) -! hflx_wat(i) = hflx(i) - ! DH* - else - zorlo(i) = huge - ! *DH - endif - if (dry(i)) then ! Land - uustar_lnd(i) = uustar(i) - weasd_lnd(i) = weasd(i) - tsfc_lnd(i) = tsfcl(i) - tsurf_lnd(i) = tsfcl(i) -! snowd_lnd(i) = snowd(i) / frland(i) - semis_lnd(i) = semis_rad(i) -! qss_lnd(i) = qss(i) -! hflx_lnd(i) = hflx(i) - ! DH* - else - zorll(i) = huge - ! *DH - endif - if (icy(i)) then ! Ice - uustar_ice(i) = uustar(i) - weasd_ice(i) = weasd(i) - tsfc_ice(i) = tisfc(i) - tsurf_ice(i) = tisfc(i) -! snowd_ice(i) = snowd(i) / cice(i) - ep1d_ice(i) = zero - gflx_ice(i) = zero - semis_ice(i) = 0.96_kind_phys -! semis_ice(i) = 0.95_kind_phys -! qss_ice(i) = qss(i) -! hflx_ice(i) = hflx(i) - ! DH* - else - zorli(i) = huge - ! *DH - endif - if (nint(slmsk(i)) /= 1) slmsk(i) = islmsk(i) - enddo - -! to prepare to separate lake from ocean under water category - do i = 1, im - if(wet(i) .and. lkm == 1) then - if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif - else - use_flake(i) = .false. - endif - enddo -! - if (frac_grid) then - do i=1,im - if (dry(i)) then - if (icy(i)) then - snowd_lnd(i) = snowd(i) / (frland(i) + cice(i)) - snowd_ice(i) = snowd_lnd(i) - else - snowd_lnd(i) = snowd(i) / frland(i) - snowd_ice(i) = zero - endif - elseif (icy(i)) then - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) / cice(i) - endif - enddo - else - do i=1,im - if (dry(i)) then - snowd_lnd(i) = snowd(i) - snowd_ice(i) = zero - elseif (icy(i)) then - snowd_lnd(i) = zero - snowd_ice(i) = snowd(i) / cice(i) - endif - enddo - endif - - ! Assign sea ice temperature to interstitial variable - do i = 1, im - tice(i) = tisfc(i) - enddo - - end subroutine GFS_surface_composites_pre_run - -end module GFS_surface_composites_pre - - -module GFS_surface_composites_inter - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_composites_inter_init, GFS_surface_composites_inter_finalize, GFS_surface_composites_inter_run - -contains - - subroutine GFS_surface_composites_inter_init () - end subroutine GFS_surface_composites_inter_init - - subroutine GFS_surface_composites_inter_finalize() - end subroutine GFS_surface_composites_inter_finalize - -!> \section arg_table_GFS_surface_composites_inter_run Argument Table -!! \htmlinclude GFS_surface_composites_inter_run.html -!! - subroutine GFS_surface_composites_inter_run (im, dry, icy, wet, semis_wat, semis_lnd, semis_ice, adjsfcdlw, & - gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat, & - adjsfcusw, adjsfcdsw, adjsfcnsw, errmsg, errflg) - - implicit none - - ! Interface variables - integer, intent(in ) :: im - logical, dimension(im), intent(in ) :: dry, icy, wet - real(kind=kind_phys), dimension(im), intent(in ) :: semis_wat, semis_lnd, semis_ice, adjsfcdlw, & - adjsfcdsw, adjsfcnsw - real(kind=kind_phys), dimension(im), intent(inout) :: gabsbdlw_lnd, gabsbdlw_ice, gabsbdlw_wat - real(kind=kind_phys), dimension(im), intent(out) :: adjsfcusw - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! --- convert lw fluxes for land/ocean/sea-ice models - requires dcyc2t3 to set adjsfcdlw - ! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. - ! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. - ! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. - ! one needs to be aware that that the absorbed downward lw flux (used by land/ocean - ! models as downward flux) is not the same as adjsfcdlw but a value reduced by - ! the factor of emissivity. however, the net effects are the same when seeing - ! it either above the surface interface or below. - ! - ! - flux above the interface used by atmosphere model: - ! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! - flux below the interface used by lnd/oc/ice models: - ! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 - ! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) - ! surface upwelling shortwave flux at current time is in adjsfcusw - - ! --- ... define the downward lw flux absorbed by ground - do i=1,im - if (dry(i)) gabsbdlw_lnd(i) = semis_lnd(i) * adjsfcdlw(i) - if (icy(i)) gabsbdlw_ice(i) = semis_ice(i) * adjsfcdlw(i) - if (wet(i)) gabsbdlw_wat(i) = semis_wat(i) * adjsfcdlw(i) - adjsfcusw(i) = adjsfcdsw(i) - adjsfcnsw(i) - enddo - - end subroutine GFS_surface_composites_inter_run - -end module GFS_surface_composites_inter - - -module GFS_surface_composites_post - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - -contains - - subroutine GFS_surface_composites_post_init () - end subroutine GFS_surface_composites_post_init - - subroutine GFS_surface_composites_post_finalize() - end subroutine GFS_surface_composites_post_finalize - -!> \section arg_table_GFS_surface_composites_post_run Argument Table -!! \htmlinclude GFS_surface_composites_post_run.html -!! - subroutine GFS_surface_composites_post_run ( & - im, kice, km, cplflx, cplwav2atm, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & - zorl, zorlo, zorll, zorli, & - cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & - stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & - uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & - cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & - ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & - tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, lprnt, ipr, kdt, errmsg, errflg) - - implicit none - - integer, intent(in) :: im, kice, km - logical, intent(in) :: cplflx, frac_grid, cplwav2atm - logical, dimension(im), intent(in) :: flag_cice, dry, wet, icy - integer, dimension(im), intent(in) :: islmsk - real(kind=kind_phys), dimension(im), intent(in) :: landfrac, lakefrac, oceanfrac, & - cd_wat, cd_lnd, cd_ice, cdq_wat, cdq_lnd, cdq_ice, rb_wat, rb_lnd, rb_ice, stress_wat, & - stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & - fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & - chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & - snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & - hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice - - real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, zorli, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & - fh2, tsurf, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc - - real(kind=kind_phys), dimension(im), intent(in ) :: tice ! interstitial sea ice temperature - real(kind=kind_phys), dimension(im), intent(inout) :: hice, cice - real(kind=kind_phys), intent(in ) :: min_seaice - - real(kind=kind_phys), dimension(im, kice), intent(in ) :: tiice - real(kind=kind_phys), dimension(im, km), intent(inout) :: stc - logical, intent(in) :: lprnt - integer, intent(in) :: ipr, kdt - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - real(kind=kind_phys) :: txl, txi, txo, wfrac - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! --- generate ocean/land/ice composites - - if (frac_grid) then - - do i=1, im - - ! Three-way composites (fields from sfc_diff) - txl = landfrac(i) ! land fraction - wfrac = one - txl ! ocean fraction - txi = cice(i) * wfrac ! txi = ice fraction wrt whole cell - txo = max(zero, wfrac-txi) ! txo = open water fraction - - zorl(i) = txl*zorll(i) + txi*zorli(i) + txo*zorlo(i) -! zorl(i) = txl*log(zorll(i)) + txi*log(zorli(i)) + txo*log(zorlo(i)) -! zorl(i) = exp(zorl(i)) - cd(i) = txl*cd_lnd(i) + txi*cd_ice(i) + txo*cd_wat(i) - cdq(i) = txl*cdq_lnd(i) + txi*cdq_ice(i) + txo*cdq_wat(i) - rb(i) = txl*rb_lnd(i) + txi*rb_ice(i) + txo*rb_wat(i) - stress(i) = txl*stress_lnd(i) + txi*stress_ice(i) + txo*stress_wat(i) - ffmm(i) = txl*ffmm_lnd(i) + txi*ffmm_ice(i) + txo*ffmm_wat(i) - ffhh(i) = txl*ffhh_lnd(i) + txi*ffhh_ice(i) + txo*ffhh_wat(i) - uustar(i) = txl*uustar_lnd(i) + txi*uustar_ice(i) + txo*uustar_wat(i) - fm10(i) = txl*fm10_lnd(i) + txi*fm10_ice(i) + txo*fm10_wat(i) - fh2(i) = txl*fh2_lnd(i) + txi*fh2_ice(i) + txo*fh2_wat(i) - !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) - !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_wat(i) ! not used again! Moorthi - cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_wat(i) - chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_wat(i) - !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) - ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) - !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_wat(i) - !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_wat(i) - weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) - snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) - !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) - - if (.not. flag_cice(i) .and. islmsk(i) == 2) then - evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) - else - evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) - hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) - qss(i) = txl*qss_lnd(i) + txi*qss_ice(i) + txo*qss_wat(i) - gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) - endif - tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_wat(i) - - if (dry(i)) then - tsfcl(i) = tsfc_lnd(i) ! over land - elseif (wet(i)) then - tsfcl(i) = tsfc_wat(i) ! over water - else - tsfcl(i) = tice(i) ! over ice - endif - if (wet(i)) then - tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled - elseif (icy(i)) then - tsfco(i) = tice(i) ! over lake or ocean ice when uncoupled - else - tsfco(i) = tsfc_lnd(i) ! over land - endif - if (icy(i)) then - tisfc(i) = tice(i) ! over lake or ocean ice when uncoupled - elseif (wet(i)) then - tisfc(i) = tsfc_wat(i) ! over lake or ocean when uncoupled - else - tisfc(i) = tsfc_lnd(i) ! over land - endif - ! for coupled model ocean will replace this -! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled -! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled - -! if (wet(i) .and. .not. cplflx) then -! tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled -! tisfc(i) = tsfc_ice(i) ! over ice when uncoupled -! endif - -! if (.not. flag_cice(i)) then -! if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array -! tisfc(i) = tice(i) -! else ! this would be over open ocean or land (no ice fraction) -! hice(i) = zero -! cice(i) = zero -! tisfc(i) = tsfc(i) -! endif -! endif - if (.not. icy(i)) then - hice(i) = zero - cice(i) = zero - endif - enddo - - else - - do i=1,im - if (islmsk(i) == 1) then - zorl(i) = zorll(i) - cd(i) = cd_lnd(i) - cdq(i) = cdq_lnd(i) - rb(i) = rb_lnd(i) - stress(i) = stress_lnd(i) - ffmm(i) = ffmm_lnd(i) - ffhh(i) = ffhh_lnd(i) - uustar(i) = uustar_lnd(i) - fm10(i) = fm10_lnd(i) - fh2(i) = fh2_lnd(i) - !tsurf(i) = tsurf_lnd(i) - tsfcl(i) = tsfc_lnd(i) ! over land - tsfc(i) = tsfcl(i) - tsfco(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_lnd(i) - chh(i) = chh_lnd(i) - gflx(i) = gflx_lnd(i) - ep1d(i) = ep1d_lnd(i) - weasd(i) = weasd_lnd(i) - snowd(i) = snowd_lnd(i) - evap(i) = evap_lnd(i) - hflx(i) = hflx_lnd(i) - qss(i) = qss_lnd(i) - hice(i) = zero - cice(i) = zero - elseif (islmsk(i) == 0) then - zorl(i) = zorlo(i) - cd(i) = cd_wat(i) - cdq(i) = cdq_wat(i) - rb(i) = rb_wat(i) - stress(i) = stress_wat(i) - ffmm(i) = ffmm_wat(i) - ffhh(i) = ffhh_wat(i) - uustar(i) = uustar_wat(i) - fm10(i) = fm10_wat(i) - fh2(i) = fh2_wat(i) - !tsurf(i) = tsurf_wat(i) - tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) - tsfc(i) = tsfco(i) - tsfcl(i) = tsfc(i) - tisfc(i) = tsfc(i) - cmm(i) = cmm_wat(i) - chh(i) = chh_wat(i) - gflx(i) = gflx_wat(i) - ep1d(i) = ep1d_wat(i) - weasd(i) = weasd_wat(i) - snowd(i) = snowd_wat(i) - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - qss(i) = qss_wat(i) - hice(i) = zero - cice(i) = zero - else ! islmsk(i) == 2 - zorl(i) = zorli(i) - cd(i) = cd_ice(i) - cdq(i) = cdq_ice(i) - rb(i) = rb_ice(i) - ffmm(i) = ffmm_ice(i) - ffhh(i) = ffhh_ice(i) - uustar(i) = uustar_ice(i) - fm10(i) = fm10_ice(i) - fh2(i) = fh2_ice(i) - stress(i) = stress_ice(i) - !tsurf(i) = tsurf_ice(i) - cmm(i) = cmm_ice(i) - chh(i) = chh_ice(i) - gflx(i) = gflx_ice(i) - ep1d(i) = ep1d_ice(i) - weasd(i) = weasd_ice(i) - snowd(i) = snowd_ice(i) - qss(i) = qss_ice(i) - tsfc(i) = tsfc_ice(i) - evap(i) = evap_ice(i) - hflx(i) = hflx_ice(i) - tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) -! - if (flag_cice(i)) then - if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_wat(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) - stress(i) = txi * stress_ice(i) + txo * stress_wat(i) - qss(i) = txi * qss_ice(i) + txo * qss_wat(i) - ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * zorli(i) + txo * zorlo(i) -! zorl(i) = txi * log(zorli(i)) + txo * log(zorlo(i)) -! zorl(i) = exp(zorl(i)) - snowd(i) = txi * snowd_ice(i) - endif - elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = cice(i)*zorli(i) + (one-cice(i))*zorlo(i) -! zorl(i) = cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i)) -! zorl(i) = exp(zorl(i)) - endif -! - if (wet(i)) then - tsfco(i) = tsfc_wat(i) - else - tsfco(i) = tsfc(i) - endif - tsfcl(i) = tsfc(i) - do k=1,min(kice,km) ! store tiice in stc to reduce output in the nonfrac grid case - stc(i,k) = tiice(i,k) - enddo - endif - - enddo - - if (lprnt) write(0,*)' tisfc=',tisfc(ipr),' tice=',tice(ipr),' kdt=',kdt - if (lprnt) write(0,*)' tsfc=',tsfc(ipr),' tice=',tice(ipr),' kdt=',kdt -! if (lprnt) write(0,*)' hflx=',hflx(ipr),' evap=',evap(ipr),' cice=',cice(ipr),' kdt=',kdt,& -! ' hflx_wat=',hflx_wat(ipr),' wet=',wet(ipr),' evap_wat=',evap_wat(ipr) - if (lprnt) write(0,*)' tiice_comp=',tiice(ipr,:) - - endif ! if (frac_grid) - - ! --- compositing done - - end subroutine GFS_surface_composites_post_run - -end module GFS_surface_composites_post diff --git a/physics/debug/GFS_surface_composites.meta_dbg b/physics/debug/GFS_surface_composites.meta_dbg deleted file mode 100644 index a68dcb2c0..000000000 --- a/physics/debug/GFS_surface_composites.meta_dbg +++ /dev/null @@ -1,1865 +0,0 @@ -[ccpp-table-properties] - name = GFS_surface_composites_pre - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[lkm] - standard_name = flag_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplwav2atm] - standard_name = flag_for_wave_coupling_to_atm - long_name = flag controlling ocean wave coupling to the atmosphere (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[landfrac] - standard_name = land_area_fraction - long_name = fraction of horizontal grid area occupied by land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lakedepth] - standard_name = lake_depth - long_name = lake depth - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[frland] - standard_name = land_area_fraction_for_microphysics - long_name = land area fraction used in microphysics schemes - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[ocean] - standard_name = flag_nonzero_ocean_surface_fraction - long_name = flag indicating presence of some ocean surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowd] - standard_name = surface_snow_thickness_water_equivalent - long_name = water equivalent snow depth - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowd_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowd_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total precipitation amount in each time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water - long_name = total precipitation amount in each time step over water - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp_lnd] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land - long_name = total precipitation amount in each time step over land - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp_ice] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice - long_name = total precipitation amount in each time step over ice - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[uustar] - standard_name = surface_friction_velocity - long_name = boundary layer parameter - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[uustar_wat] - standard_name = surface_friction_velocity_over_water - long_name = surface friction velocity over water - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[uustar_lnd] - standard_name = surface_friction_velocity_over_land - long_name = surface friction velocity over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[uustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[weasd] - standard_name = water_equivalent_accumulated_snow_depth - long_name = water equiv of acc snow depth over land and sea ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[weasd_lnd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[weasd_ice] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ep1d_ice] - standard_name = surface_upward_potential_latent_heat_flux_over_ice - long_name = surface upward potential latent heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfcl] - standard_name = surface_skin_temperature_over_land - long_name = surface skin temperature over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_water_interstitial - long_name = surface skin temperature over water (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_lnd] - standard_name = surface_skin_temperature_over_land_interstitial - long_name = surface skin temperature over land (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_ice] - standard_name = surface_skin_temperature_over_ice_interstitial - long_name = surface skin temperature over ice (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tice] - standard_name = sea_ice_temperature_interstitial - long_name = sea ice surface skin temperature use as interstitial - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[tsurf] - standard_name = surface_skin_temperature_after_iteration - long_name = surface skin temperature after iteration - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf_lnd] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gflx_ice] - standard_name = upward_heat_flux_in_soil_over_ice - long_name = soil heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[slmsk] - standard_name = sea_land_ice_mask_real - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_rad] - standard_name = surface_longwave_emissivity - long_name = surface lw emissivity in fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[semis_wat] - standard_name = surface_longwave_emissivity_over_water_interstitial - long_name = surface lw emissivity in fraction over water (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_lnd] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qss] - standard_name = surface_specific_humidity - long_name = surface air saturation specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[qss_wat] - standard_name = surface_specific_humidity_over_water - long_name = surface air saturation specific humidity over water - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qss_lnd] - standard_name = surface_specific_humidity_over_land - long_name = surface air saturation specific humidity over land - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qss_ice] - standard_name = surface_specific_humidity_over_ice - long_name = surface air saturation specific humidity over ice - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux - long_name = kinematic surface upward sensible heat flux - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflx_wat] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_water - long_name = kinematic surface upward sensible heat flux over water - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx_lnd] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_land - long_name = kinematic surface upward sensible heat flux over land - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx_ice] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice - long_name = kinematic surface upward sensible heat flux over ice - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[zorlo] - standard_name = surface_roughness_length_over_water - long_name = surface roughness length over water - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorll] - standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[xlon] - standard_name = longitude - long_name = longitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[xlat] - standard_name = latitude - long_name = latitude - units = radian - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = inout - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = inout - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_surface_composites_inter - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_inter_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[semis_wat] - standard_name = surface_longwave_emissivity_over_water_interstitial - long_name = surface lw emissivity in fraction over water (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[semis_lnd] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[semis_ice] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gabsbdlw_lnd] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land - long_name = total sky surface downward longwave flux absorbed by the ground over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gabsbdlw_ice] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice - long_name = total sky surface downward longwave flux absorbed by the ground over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gabsbdlw_wat] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_water - long_name = total sky surface downward longwave flux absorbed by the ground over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[adjsfcusw] - standard_name = surface_upwelling_shortwave_flux - long_name = surface upwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcnsw] - standard_name = surface_net_downwelling_shortwave_flux - long_name = surface net downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_surface_composites_post - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_composites_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[kice] - standard_name = ice_vertical_dimension - long_name = vertical loop extent for ice levels, start at 1 - units = count - dimensions = () - type = integer - intent = in - optional = F -[km] - standard_name = soil_vertical_dimension - long_name = soil vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplwav2atm] - standard_name = flag_for_wave_coupling_to_atm - long_name = flag controlling ocean wave coupling to the atmosphere (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[landfrac] - standard_name = land_area_fraction - long_name = fraction of horizontal grid area occupied by land - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lakefrac] - standard_name = lake_area_fraction - long_name = fraction of horizontal grid area occupied by lake - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorlo] - standard_name = surface_roughness_length_over_water - long_name = surface roughness length over water - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorll] - standard_name = surface_roughness_length_over_land - long_name = surface roughness length over land - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorli] - standard_name = surface_roughness_length_over_ice - long_name = surface roughness length over ice - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cd] - standard_name = surface_drag_coefficient_for_momentum_in_air - long_name = surface exchange coeff for momentum - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cd_wat] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_water - long_name = surface exchange coeff for momentum over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cd_lnd] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_land - long_name = surface exchange coeff for momentum over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cd_ice] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice - long_name = surface exchange coeff for momentum over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cdq] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air - long_name = surface exchange coeff heat & moisture - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cdq_wat] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_water - long_name = surface exchange coeff heat surface exchange coeff heat & moisture over ocean moisture over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cdq_lnd] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land - long_name = surface exchange coeff heat & moisture over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cdq_ice] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice - long_name = surface exchange coeff heat & moisture over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rb] - standard_name = bulk_richardson_number_at_lowest_model_level - long_name = bulk Richardson number at the surface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rb_wat] - standard_name = bulk_richardson_number_at_lowest_model_level_over_water - long_name = bulk Richardson number at the surface over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rb_lnd] - standard_name = bulk_richardson_number_at_lowest_model_level_over_land - long_name = bulk Richardson number at the surface over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[rb_ice] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ice - long_name = bulk Richardson number at the surface over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[stress] - standard_name = surface_wind_stress - long_name = surface wind stress - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[stress_wat] - standard_name = surface_wind_stress_over_water - long_name = surface wind stress over water - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[stress_lnd] - standard_name = surface_wind_stress_over_land - long_name = surface wind stress over land - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[stress_ice] - standard_name = surface_wind_stress_over_ice - long_name = surface wind stress over ice - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffmm] - standard_name = Monin_Obukhov_similarity_function_for_momentum - long_name = Monin-Obukhov similarity function for momentum - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ffmm_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water - long_name = Monin-Obukhov similarity function for momentum over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffmm_lnd] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land - long_name = Monin-Obukhov similarity function for momentum over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffmm_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice - long_name = Monin-Obukhov similarity function for momentum over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffhh] - standard_name = Monin_Obukhov_similarity_function_for_heat - long_name = Monin-Obukhov similarity function for heat - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ffhh_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_water - long_name = Monin-Obukhov similarity function for heat over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffhh_lnd] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_land - long_name = Monin-Obukhov similarity function for heat over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ffhh_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice - long_name = Monin-Obukhov similarity function for heat over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[uustar] - standard_name = surface_friction_velocity - long_name = boundary layer parameter - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[uustar_wat] - standard_name = surface_friction_velocity_over_water - long_name = surface friction velocity over water - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[uustar_lnd] - standard_name = surface_friction_velocity_over_land - long_name = surface friction velocity over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[uustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fm10] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m - long_name = Monin-Obukhov similarity parameter for momentum at 10m - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm10_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water - long_name = Monin-Obukhov similarity parameter for momentum at 10m over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fm10_lnd] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land - long_name = Monin-Obukhov similarity parameter for momentum at 10m over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fm10_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fh2] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m - long_name = Monin-Obukhov similarity parameter for heat at 2m - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh2_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_water - long_name = Monin-Obukhov similarity parameter for heat at 2m over water - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fh2_lnd] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land - long_name = Monin-Obukhov similarity parameter for heat at 2m over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fh2_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice - long_name = Monin-Obukhov similarity parameter for heat at 2m over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf] - standard_name = surface_skin_temperature_after_iteration - long_name = surface skin temperature after iteration - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_water - long_name = surface skin temperature after iteration over water - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf_lnd] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cmm] - standard_name = surface_drag_wind_speed_for_momentum_in_air - long_name = momentum exchange coefficient - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cmm_wat] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_water - long_name = momentum exchange coefficient over water - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cmm_lnd] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land - long_name = momentum exchange coefficient over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cmm_ice] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice - long_name = momentum exchange coefficient over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[chh] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air - long_name = thermal exchange coefficient - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[chh_wat] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_water - long_name = thermal exchange coefficient over water - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[chh_lnd] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land - long_name = thermal exchange coefficient over land - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[chh_ice] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice - long_name = thermal exchange coefficient over ice - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gflx] - standard_name = upward_heat_flux_in_soil - long_name = soil heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gflx_wat] - standard_name = upward_heat_flux_in_soil_over_water - long_name = soil heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gflx_lnd] - standard_name = upward_heat_flux_in_soil_over_land - long_name = soil heat flux over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gflx_ice] - standard_name = upward_heat_flux_in_soil_over_ice - long_name = soil heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ep1d] - standard_name = surface_upward_potential_latent_heat_flux - long_name = surface upward potential latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ep1d_wat] - standard_name = surface_upward_potential_latent_heat_flux_over_water - long_name = surface upward potential latent heat flux over water - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ep1d_lnd] - standard_name = surface_upward_potential_latent_heat_flux_over_land - long_name = surface upward potential latent heat flux over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ep1d_ice] - standard_name = surface_upward_potential_latent_heat_flux_over_ice - long_name = surface upward potential latent heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[weasd] - standard_name = water_equivalent_accumulated_snow_depth - long_name = water equiv of acc snow depth over land and sea ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[weasd_lnd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[weasd_ice] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snowd] - standard_name = surface_snow_thickness_water_equivalent - long_name = water equivalent snow depth - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snowd_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snowd_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep - long_name = total precipitation amount in each time step - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp_wat] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_water - long_name = total precipitation amount in each time step over water - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tprcp_lnd] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land - long_name = total precipitation amount in each time step over land - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tprcp_ice] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice - long_name = total precipitation amount in each time step over ice - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux - long_name = kinematic surface upward latent heat flux - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evap_wat] - standard_name = kinematic_surface_upward_latent_heat_flux_over_water - long_name = kinematic surface upward latent heat flux over water - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evap_lnd] - standard_name = kinematic_surface_upward_latent_heat_flux_over_land - long_name = kinematic surface upward latent heat flux over land - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evap_ice] - standard_name = kinematic_surface_upward_latent_heat_flux_over_ice - long_name = kinematic surface upward latent heat flux over ice - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux - long_name = kinematic surface upward sensible heat flux - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx_wat] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_water - long_name = kinematic surface upward sensible heat flux over water - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflx_lnd] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_land - long_name = kinematic surface upward sensible heat flux over land - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflx_ice] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice - long_name = kinematic surface upward sensible heat flux over ice - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[qss] - standard_name = surface_specific_humidity - long_name = surface air saturation specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qss_wat] - standard_name = surface_specific_humidity_over_water - long_name = surface air saturation specific humidity over water - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[qss_lnd] - standard_name = surface_specific_humidity_over_land - long_name = surface air saturation specific humidity over land - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[qss_ice] - standard_name = surface_specific_humidity_over_ice - long_name = surface air saturation specific humidity over ice - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfcl] - standard_name = surface_skin_temperature_over_land - long_name = surface skin temperature over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_water_interstitial - long_name = surface skin temperature over water (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc_lnd] - standard_name = surface_skin_temperature_over_land_interstitial - long_name = surface skin temperature over land (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc_ice] - standard_name = surface_skin_temperature_over_ice_interstitial - long_name = surface skin temperature over ice (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea ice surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tice] - standard_name = sea_ice_temperature_interstitial - long_name = sea ice surface skin temperature use as interstitial - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cice] - standard_name = sea_ice_concentration - long_name = ice fraction over open water - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in -[tiice] - standard_name = internal_ice_temperature - long_name = sea ice internal temperature - units = K - dimensions = (horizontal_loop_extent,ice_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[stc] - standard_name = soil_temperature - long_name = soil temperature - units = K - dimensions = (horizontal_loop_extent,soil_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/GFS_surface_generic.F90_dbg b/physics/debug/GFS_surface_generic.F90_dbg deleted file mode 100644 index a26633a5a..000000000 --- a/physics/debug/GFS_surface_generic.F90_dbg +++ /dev/null @@ -1,400 +0,0 @@ -!> \file GFS_surface_generic.F90 -!! Contains code related to all GFS surface schemes. - - module GFS_surface_generic_pre - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - - contains - - subroutine GFS_surface_generic_pre_init () - end subroutine GFS_surface_generic_pre_init - - subroutine GFS_surface_generic_pre_finalize() - end subroutine GFS_surface_generic_pre_finalize - -!> \section arg_table_GFS_surface_generic_pre_run Argument Table -!! \htmlinclude GFS_surface_generic_pre_run.html -!! - subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & - prsik_1, prslk_1, tsfc, phil, con_g, & - lprnt, ipr, kdt, & - sigmaf, soiltyp, vegtype, slopetyp, work3, tsurf, zlvl, & - drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & - lndp_var_list, lndp_prt_list, & - z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, sfc_wts_inv, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) - - use surface_perturbation, only: cdfnor - - implicit none - - ! Interface variables - logical, intent(in) :: lprnt - integer, intent(in) :: im, levs, isot, ivegsrc, ipr, kdt - integer, dimension(im), intent(in) :: islmsk - integer, dimension(im), intent(inout) :: soiltyp, vegtype, slopetyp - - real(kind=kind_phys), intent(in) :: con_g - real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1 - - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc - real(kind=kind_phys), dimension(im,levs), intent(in) :: phil - - real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, tsurf, zlvl - - ! Stochastic physics / surface perturbations - real(kind=kind_phys), dimension(im), intent(out) :: drain_cpl - real(kind=kind_phys), dimension(im), intent(out) :: dsnow_cpl - real(kind=kind_phys), dimension(im), intent(in) :: rain_cpl - real(kind=kind_phys), dimension(im), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type - integer, intent(in) :: n_var_lndp - character(len=3), dimension(n_var_lndp), intent(in) :: lndp_var_list - real(kind=kind_phys), dimension(n_var_lndp), intent(in) :: lndp_prt_list - real(kind=kind_phys), dimension(im,n_var_lndp), intent(in) :: sfc_wts - real(kind=kind_phys), dimension(im), intent(out) :: z01d - real(kind=kind_phys), dimension(im), intent(out) :: zt1d - real(kind=kind_phys), dimension(im), intent(out) :: bexp1d - real(kind=kind_phys), dimension(im), intent(out) :: xlai1d - real(kind=kind_phys), dimension(im), intent(out) :: vegf1d - real(kind=kind_phys), intent(out) :: lndp_vgf - real(kind=kind_phys), dimension(im,n_var_lndp), intent(inout) :: sfc_wts_inv - - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl - logical, dimension(im), intent(inout) :: flag_cice - integer, dimension(im), intent(out) :: islmsk_cice - - real(kind=kind_phys), dimension(im), intent(out) :: wind - real(kind=kind_phys), dimension(im), intent(in ) :: u1, v1 - ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(im), intent(inout ) :: cnvwind - ! - real(kind=kind_phys), dimension(im), intent(out) :: smcwlt2, smcref2 - - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: i, k - real(kind=kind_phys) :: onebg - real(kind=kind_phys) :: cdfz - - ! Set constants - onebg = 1.0/con_g - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - - ! Scale random patterns for surface perturbations with perturbation size - ! Turn vegetation fraction pattern into percentile pattern - lndp_vgf=-999. - - if (lprnt) write(0,*)' lndp_type=',lndp_type - if (lndp_type>0) then - sfc_wts_inv(:,:)=sfc_wts(:,:) - endif - if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') - z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') - xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') - ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff - do i=1,im - call cdfnor(sfc_wts(i,k),cdfz) - vegf1d(i) = cdfz - enddo - lndp_vgf = lndp_prt_list(k) - end select - enddo - endif - - ! End of stochastic physics / surface perturbation - - do i=1,im - sigmaf(i) = max(vfrac(i), 0.01_kind_phys) - islmsk_cice(i) = islmsk(i) - if (islmsk(i) == 2) then - if (isot == 1) then - soiltyp(i) = 16 - else - soiltyp(i) = 9 - endif - if (ivegsrc == 0 .or. ivegsrc == 4) then - vegtype(i) = 24 - elseif (ivegsrc == 1) then - vegtype(i) = 15 - elseif (ivegsrc == 2) then - vegtype(i) = 13 - elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vegtype(i) = 15 - endif - slopetyp(i) = 9 - else - soiltyp(i) = int( stype(i)+0.5_kind_phys ) - vegtype(i) = int( vtype(i)+0.5_kind_phys ) - slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp - if (soiltyp(i) < 1) soiltyp(i) = 14 - if (vegtype(i) < 1) vegtype(i) = 17 - if (slopetyp(i) < 1) slopetyp(i) = 1 - endif - - work3(i) = prsik_1(i) / prslk_1(i) - - if (lprnt .and. i == ipr) then - write(0,*)' phil=',phil(i,1),' u1=',u1(i),' v1=',v1(i),& - ' cnvwind=',cnvwind(i),' onebg=',onebg,' work3=',work3(i) - endif - - !tsurf(i) = tsfc(i) - zlvl(i) = phil(i,1) * onebg - smcwlt2(i) = zero - smcref2(i) = zero - - wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) - cnvwind(i) = zero - - enddo - - if (cplflx) then - do i=1,im - islmsk_cice(i) = nint(slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - enddo - endif - - end subroutine GFS_surface_generic_pre_run - - end module GFS_surface_generic_pre - - - module GFS_surface_generic_post - - use machine, only: kind_phys - - implicit none - - private - - public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run - - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - - contains - - subroutine GFS_surface_generic_post_init () - end subroutine GFS_surface_generic_post_init - - subroutine GFS_surface_generic_post_finalize() - end subroutine GFS_surface_generic_post_finalize - -!> \section arg_table_GFS_surface_generic_post_run Argument Table -!! \htmlinclude GFS_surface_generic_post_run.html -!! - subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& - adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & - adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & - epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & - dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & - v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & - nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & - runoff, srunoff, runof, drain, lheatstrg, z0fac, e0fac, zorl, hflx, evap, hflxq, evapq, hffac, hefac, errmsg, errflg) - - implicit none - - integer, intent(in) :: im - logical, intent(in) :: cplflx, cplwav, lssav - logical, dimension(im), intent(in) :: icy, wet - real(kind=kind_phys), intent(in) :: dtf - - real(kind=kind_phys), dimension(im), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & - adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & - t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf - - real(kind=kind_phys), dimension(im), intent(inout) :: epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, & - dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, & - nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, & - nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, & - evcwa, transa, sbsnoa, snowca, snohfa, ep - - real(kind=kind_phys), dimension(im), intent(inout) :: runoff, srunoff - real(kind=kind_phys), dimension(im), intent(in) :: drain, runof - - ! For canopy heat storage - logical, intent(in) :: lheatstrg - real(kind=kind_phys), intent(in) :: z0fac, e0fac - real(kind=kind_phys), dimension(im), intent(in) :: zorl - real(kind=kind_phys), dimension(im), intent(in) :: hflx, evap - real(kind=kind_phys), dimension(im), intent(out) :: hflxq, evapq - real(kind=kind_phys), dimension(im), intent(out) :: hffac, hefac - - ! CCPP error handling variables - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys - - ! Parameters for canopy heat storage parametrization - real(kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 - real(kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 - - integer :: i - real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl - real(kind=kind_phys) :: tem, tem1, tem2 - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - do i=1,im - epi(i) = ep1d(i) - gfluxi(i) = gflx(i) - t1(i) = tgrs_1(i) - q1(i) = qgrs_1(i) - u1(i) = ugrs_1(i) - v1(i) = vgrs_1(i) - enddo - - if (cplflx .or. cplwav) then - do i=1,im - u10mi_cpl(i) = u10m(i) - v10mi_cpl(i) = v10m(i) - enddo - endif - - if (cplflx) then - do i=1,im - dlwsfci_cpl (i) = adjsfcdlw(i) - dswsfci_cpl (i) = adjsfcdsw(i) - dlwsfc_cpl (i) = dlwsfc_cpl(i) + adjsfcdlw(i)*dtf - dswsfc_cpl (i) = dswsfc_cpl(i) + adjsfcdsw(i)*dtf - dnirbmi_cpl (i) = adjnirbmd(i) - dnirdfi_cpl (i) = adjnirdfd(i) - dvisbmi_cpl (i) = adjvisbmd(i) - dvisdfi_cpl (i) = adjvisdfd(i) - dnirbm_cpl (i) = dnirbm_cpl(i) + adjnirbmd(i)*dtf - dnirdf_cpl (i) = dnirdf_cpl(i) + adjnirdfd(i)*dtf - dvisbm_cpl (i) = dvisbm_cpl(i) + adjvisbmd(i)*dtf - dvisdf_cpl (i) = dvisdf_cpl(i) + adjvisdfd(i)*dtf - nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) - if (wet(i)) then - nlwsfci_cpl(i) = adjsfcdlw(i) - adjsfculw_wat(i) - endif - nlwsfc_cpl (i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf - t2mi_cpl (i) = t2m(i) - q2mi_cpl (i) = q2m(i) - tsfci_cpl (i) = tsfc(i) -! tsfci_cpl (i) = tsfc_wat(i) - psurfi_cpl (i) = pgr(i) - enddo - -! --- estimate mean albedo for ocean point without ice cover and apply -! them to net SW heat fluxes - - do i=1,im -! if (Sfcprop%landfrac(i) < one) then ! Not 100% land - if (wet(i)) then ! some open water -! --- compute open water albedo - xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl = 0.06_kind_phys - ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & - & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & - & * (xcosz_loc-one)) - ocalvisdf_cpl = 0.06_kind_phys - ocalvisbm_cpl = ocalnirbm_cpl - - nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) - nnirdfi_cpl(i) = adjnirdfd(i) * (one-ocalnirdf_cpl) - nvisbmi_cpl(i) = adjvisbmd(i) * (one-ocalvisbm_cpl) - nvisdfi_cpl(i) = adjvisdfd(i) * (one-ocalvisdf_cpl) - else - nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) - nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) - nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) - nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) - endif - nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) & - + nvisbmi_cpl(i) + nvisdfi_cpl(i) - nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf - nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf - nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf - nvisbm_cpl(i) = nvisbm_cpl(i) + nvisbmi_cpl(i)*dtf - nvisdf_cpl(i) = nvisdf_cpl(i) + nvisdfi_cpl(i)*dtf - enddo - endif - - if (lssav) then - do i=1,im - gflux(i) = gflux(i) + gflx(i) * dtf - evbsa(i) = evbsa(i) + evbs(i) * dtf - evcwa(i) = evcwa(i) + evcw(i) * dtf - transa(i) = transa(i) + trans(i) * dtf - sbsnoa(i) = sbsnoa(i) + sbsno(i) * dtf - snowca(i) = snowca(i) + snowc(i) * dtf - snohfa(i) = snohfa(i) + snohf(i) * dtf - ep(i) = ep(i) + ep1d(i) * dtf - -! --- ... total runoff is composed of drainage into water table and -! runoff at the surface and is accumulated in unit of meters - runoff(i) = runoff(i) + (drain(i)+runof(i)) * dtf - srunoff(i) = srunoff(i) + runof(i) * dtf - enddo - endif - -! --- ... Boundary Layer and Free atmospheic turbulence parameterization -! -! in order to achieve heat storage within canopy layer, in the canopy heat -! storage parameterization the kinematic sensible and latent heat fluxes -! (hflx & evap) as surface boundary forcings to the pbl scheme are -! reduced as a function of surface roughness -! - do i=1,im - hflxq(i) = hflx(i) - evapq(i) = evap(i) - hffac(i) = one - hefac(i) = one - enddo - if (lheatstrg) then - do i=1,im - tem = 0.01_kind_phys * zorl(i) ! change unit from cm to m - tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, zero), one) - tem = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) - tem1 = (tem - u10min) / (u10max - u10min) - tem2 = one - min(max(tem1, zero), one) - hffac(i) = tem2 * hffac(i) - hefac(i) = one + e0fac * hffac(i) - hffac(i) = one + hffac(i) - hflxq(i) = hflx(i) / hffac(i) - evapq(i) = evap(i) / hefac(i) - enddo - endif - - end subroutine GFS_surface_generic_post_run - - end module GFS_surface_generic_post diff --git a/physics/debug/GFS_surface_generic.meta_dbg b/physics/debug/GFS_surface_generic.meta_dbg deleted file mode 100644 index 5df487194..000000000 --- a/physics/debug/GFS_surface_generic.meta_dbg +++ /dev/null @@ -1,1354 +0,0 @@ -[ccpp-table-properties] - name = GFS_surface_generic_pre - type = scheme - dependencies = machine.F,surface_perturbation.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_generic_pre_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[levs] - standard_name = vertical_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in - optional = F -[vfrac] - standard_name = vegetation_area_fraction - long_name = areal fractional cover of green vegetation - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[isot] - standard_name = soil_type_dataset_choice - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[ivegsrc] - standard_name = vegetation_type_dataset_choice - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[stype] - standard_name = soil_type_classification_real - long_name = soil type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[vtype] - standard_name = vegetation_type_classification_real - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[slope] - standard_name = surface_slope_classification_real - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsik_1] - standard_name = dimensionless_exner_function_at_lowest_model_interface - long_name = dimensionless Exner function at lowest model interface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslk_1] - standard_name = dimensionless_exner_function_at_lowest_model_layer - long_name = dimensionless Exner function at lowest model layer - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[phil] - standard_name = geopotential - long_name = geopotential at model layer centers - units = m2 s-2 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[con_g] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = inout - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = inout - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[soiltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[slopetyp] - standard_name = surface_slope_classification - long_name = surface slope type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[work3] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf] - standard_name = surface_skin_temperature_after_iteration - long_name = surface skin temperature after iteration - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zlvl] - standard_name = height_above_ground_at_lowest_model_layer - long_name = layer 1 height above ground (not MSL) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[drain_cpl] - standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling - long_name = change in rain_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[dsnow_cpl] - standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling - long_name = change in show_cpl (coupling_type) - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[rain_cpl] - standard_name = lwe_thickness_of_precipitation_amount_for_coupling - long_name = total rain precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snow_cpl] - standard_name = lwe_thickness_of_snow_amount_for_coupling - long_name = total snow precipitation - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lndp_type] - standard_name = index_for_stochastic_land_surface_perturbation_type - long_name = index for stochastic land surface perturbations type - units = index - dimensions = () - type = integer - intent = in - optional = F -[n_var_lndp] - standard_name = number_of_land_surface_variables_perturbed - long_name = number of land surface variables perturbed - units = count - dimensions = () - type = integer - intent = in - optional = F -[sfc_wts] - standard_name = weights_for_stochastic_surface_physics_perturbation - long_name = weights for stochastic surface physics perturbation - units = none - dimensions = (horizontal_loop_extent,number_of_land_surface_variables_perturbed) - type = real - kind = kind_phys - intent = in - optional = F -[sfc_wts_inv] - standard_name = weights_for_stochastic_surface_physics_perturbation_flipped - long_name = weights for stochastic surface physics perturbation, flipped - units = none - dimensions = (horizontal_loop_extent,number_of_land_surface_variables_perturbed) - type = real - kind = kind_phys - intent = inout - optional = F -[lndp_prt_list] - standard_name = magnitude_of_perturbations_for_landperts - long_name = magnitude of perturbations for landperts - units = variable - dimensions = (number_of_land_surface_variables_perturbed) - type = real - kind = kind_phys - intent = in - optional = F -[lndp_var_list] - standard_name = variables_to_be_perturbed_for_landperts - long_name = variables to be perturbed for landperts - units = none - dimensions = (number_of_land_surface_variables_perturbed) - type = character - kind = len=3 - intent = in - optional = F -[z01d] - standard_name = perturbation_of_momentum_roughness_length - long_name = perturbation of momentum roughness length - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[zt1d] - standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = perturbation of heat to momentum roughness length ratio - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[bexp1d] - standard_name = perturbation_of_soil_type_b_parameter - long_name = perturbation of soil type "b" parameter - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[xlai1d] - standard_name = perturbation_of_leaf_area_index - long_name = perturbation of leaf area index - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[vegf1d] - standard_name = perturbation_of_vegetation_fraction - long_name = perturbation of vegetation fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[lndp_vgf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - units = frac - dimensions = () - type = real - kind = kind_phys - intent = out - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = inout - optional = F -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = out - optional = F -[slimskin_cpl] - standard_name = sea_land_ice_mask_in - long_name = sea/land/ice mask input (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer - long_name = zonal wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer - long_name = meridional wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cnvwind] - standard_name = surface_wind_enhancement_due_to_convection - long_name = surface wind enhancement due to convection - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[smcwlt2] - standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point - long_name = wilting point (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[smcref2] - standard_name = threshold_volume_fraction_of_condensed_water_in_soil - long_name = soil moisture threshold (volumetric) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-table-properties] - name = GFS_surface_generic_post - type = scheme - dependencies = machine.F,surface_perturbation.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_surface_generic_post_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[cplwav] - standard_name = flag_for_wave_coupling - long_name = flag controlling cplwav collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[lssav] - standard_name = flag_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[dtf] - standard_name = time_step_for_dynamics - long_name = dynamics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[ep1d] - standard_name = surface_upward_potential_latent_heat_flux - long_name = surface upward potential latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[gflx] - standard_name = upward_heat_flux_in_soil - long_name = upward soil heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tgrs_1] - standard_name = air_temperature_at_lowest_model_layer - long_name = mean temperature at lowest model layer - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[qgrs_1] - standard_name = water_vapor_specific_humidity_at_lowest_model_layer - long_name = specific humidity at lowest model layer - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ugrs_1] - standard_name = x_wind_at_lowest_model_layer - long_name = zonal wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[vgrs_1] - standard_name = y_wind_at_lowest_model_layer - long_name = meridional wind at lowest model layer - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdlw] - standard_name = surface_downwelling_longwave_flux - long_name = surface downwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = surface downwelling shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjnirbmd] - standard_name = surface_downwelling_direct_near_infrared_shortwave_flux - long_name = surface downwelling beam near-infrared shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjnirdfd] - standard_name = surface_downwelling_diffuse_near_infrared_shortwave_flux - long_name = surface downwelling diffuse near-infrared shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjvisbmd] - standard_name = surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux - long_name = surface downwelling beam ultraviolet plus visible shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjvisdfd] - standard_name = surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux - long_name = surface downwelling diffuse ultraviolet plus visible shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfculw] - standard_name = surface_upwelling_longwave_flux - long_name = surface upwelling longwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjsfculw_wat] - standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial - long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjnirbmu] - standard_name = surface_upwelling_direct_near_infrared_shortwave_flux - long_name = surface upwelling beam near-infrared shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjnirdfu] - standard_name = surface_upwelling_diffuse_near_infrared_shortwave_flux - long_name = surface upwelling diffuse near-infrared shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjvisbmu] - standard_name = surface_upwelling_direct_ultraviolet_and_visible_shortwave_flux - long_name = surface upwelling beam ultraviolet plus visible shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[adjvisdfu] - standard_name = surface_upwelling_diffuse_ultraviolet_and_visible_shortwave_flux - long_name = surface upwelling diffuse ultraviolet plus visible shortwave flux at current time - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[t2m] - standard_name = temperature_at_2m - long_name = 2 meter temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[q2m] - standard_name = specific_humidity_at_2m - long_name = 2 meter specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[u10m] - standard_name = x_wind_at_10m - long_name = 10 meter u wind speed - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[v10m] - standard_name = y_wind_at_10m - long_name = 10 meter v wind speed - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc] - standard_name = surface_skin_temperature - long_name = surface skin temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[pgr] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[xcosz] - standard_name = instantaneous_cosine_of_zenith_angle - long_name = cosine of zenith angle at current time - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evbs] - standard_name = soil_upward_latent_heat_flux - long_name = soil upward latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evcw] - standard_name = canopy_upward_latent_heat_flux - long_name = canopy upward latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[trans] - standard_name = transpiration_flux - long_name = total plant transpiration rate - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sbsno] - standard_name = snow_deposition_sublimation_upward_latent_heat_flux - long_name = latent heat flux from snow depo/subl - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snowc] - standard_name = surface_snow_area_fraction - long_name = surface snow area fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snohf] - standard_name = snow_freezing_rain_upward_latent_heat_flux - long_name = latent heat flux due to snow and frz rain - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[epi] - standard_name = instantaneous_surface_potential_evaporation - long_name = instantaneous sfc potential evaporation - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gfluxi] - standard_name = instantaneous_surface_ground_heat_flux - long_name = instantaneous sfc ground heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[t1] - standard_name = air_temperature_at_lowest_model_layer_for_diag - long_name = layer 1 temperature for diag - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[q1] - standard_name = water_vapor_specific_humidity_at_lowest_model_layer_for_diag - long_name = layer 1 specific humidity for diag - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[u1] - standard_name = x_wind_at_lowest_model_layer_for_diag - long_name = layer 1 x wind for diag - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[v1] - standard_name = y_wind_at_lowest_model_layer_for_diag - long_name = layer 1 y wind for diag - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dlwsfci_cpl] - standard_name = instantaneous_surface_downwelling_longwave_flux_for_coupling - long_name = instantaneous sfc downward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dswsfci_cpl] - standard_name = instantaneous_surface_downwelling_shortwave_flux_for_coupling - long_name = instantaneous sfc downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dlwsfc_cpl] - standard_name = cumulative_surface_downwelling_longwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc downward lw flux mulitplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dswsfc_cpl] - standard_name = cumulative_surface_downwelling_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dnirbmi_cpl] - standard_name = instantaneous_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling - long_name = instantaneous sfc nir beam downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dnirdfi_cpl] - standard_name = instantaneous_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling - long_name = instantaneous sfc nir diff downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dvisbmi_cpl] - standard_name = instantaneous_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling - long_name = instantaneous sfc uv+vis beam downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dvisdfi_cpl] - standard_name = instantaneous_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling - long_name = instantaneous sfc uv+vis diff downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dnirbm_cpl] - standard_name = cumulative_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc nir beam downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dnirdf_cpl] - standard_name = cumulative_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc nir diff downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dvisbm_cpl] - standard_name = cumulative_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc uv+vis beam dnwd sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[dvisdf_cpl] - standard_name = cumulative_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative sfc uv+vis diff dnwd sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nlwsfci_cpl] - standard_name = instantaneous_surface_net_downward_longwave_flux_for_coupling - long_name = instantaneous net sfc downward lw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nlwsfc_cpl] - standard_name = cumulative_surface_net_downward_longwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net downward lw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[t2mi_cpl] - standard_name = instantaneous_temperature_at_2m_for_coupling - long_name = instantaneous T2m - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[q2mi_cpl] - standard_name = instantaneous_specific_humidity_at_2m_for_coupling - long_name = instantaneous Q2m - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[u10mi_cpl] - standard_name = instantaneous_x_wind_at_10m_for_coupling - long_name = instantaneous U10m - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[v10mi_cpl] - standard_name = instantaneous_y_wind_at_10m_for_coupling - long_name = instantaneous V10m - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsfci_cpl] - standard_name = instantaneous_surface_skin_temperature_for_coupling - long_name = instantaneous sfc temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[psurfi_cpl] - standard_name = instantaneous_surface_air_pressure_for_coupling - long_name = instantaneous sfc pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nnirbmi_cpl] - standard_name = instantaneous_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling - long_name = instantaneous net nir beam sfc downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nnirdfi_cpl] - standard_name = instantaneous_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling - long_name = instantaneous net nir diff sfc downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nvisbmi_cpl] - standard_name = instantaneous_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling - long_name = instantaneous net uv+vis beam downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nvisdfi_cpl] - standard_name = instantaneous_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling - long_name = instantaneous net uv+vis diff downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nswsfci_cpl] - standard_name = instantaneous_surface_net_downward_shortwave_flux_for_coupling - long_name = instantaneous net sfc downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nswsfc_cpl] - standard_name = cumulative_surface_net_downward_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nnirbm_cpl] - standard_name = cumulative_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net nir beam downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nnirdf_cpl] - standard_name = cumulative_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net nir diff downward sw flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nvisbm_cpl] - standard_name = cumulative_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net uv+vis beam downward sw rad flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[nvisdf_cpl] - standard_name = cumulative_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep - long_name = cumulative net uv+vis diff downward sw rad flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gflux] - standard_name = cumulative_surface_ground_heat_flux_multiplied_by_timestep - long_name = cumulative groud conductive heat flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evbsa] - standard_name = cumulative_soil_upward_latent_heat_flux_multiplied_by_timestep - long_name = cumulative soil upward latent heat flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evcwa] - standard_name = cumulative_canopy_upward_latent_heat_flu_multiplied_by_timestep - long_name = cumulative canopy upward latent heat flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[transa] - standard_name = cumulative_transpiration_flux_multiplied_by_timestep - long_name = cumulative total plant transpiration rate multiplied by timestep - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[sbsnoa] - standard_name = cumulative_snow_deposition_sublimation_upward_latent_heat_flux_multiplied_by_timestep - long_name = cumulative latent heat flux from snow depo/subl multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowca] - standard_name = cumulative_surface_snow_area_fraction_multiplied_by_timestep - long_name = cumulative surface snow area fraction multiplied by timestep - units = s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snohfa] - standard_name = cumulative_snow_freezing_rain_upward_latent_heat_flux_multiplied_by_timestep - long_name = cumulative latent heat flux due to snow and frz rain multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ep] - standard_name = cumulative_surface_upward_potential_latent_heat_flux_multiplied_by_timestep - long_name = cumulative surface upward potential latent heat flux multiplied by timestep - units = W m-2 s - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[runoff] - standard_name = total_runoff - long_name = total water runoff - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[srunoff] - standard_name = surface_runoff - long_name = surface water runoff (from lsm) - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[runof] - standard_name = surface_runoff_flux - long_name = surface runoff flux - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[drain] - standard_name = subsurface_runoff_flux - long_name = subsurface runoff flux - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lheatstrg] - standard_name = flag_for_canopy_heat_storage - long_name = flag for canopy heat storage parameterization - units = flag - dimensions = () - type = logical - intent = in - optional = F -[z0fac] - standard_name = surface_roughness_fraction_factor - long_name = surface roughness fraction factor for canopy heat storage parameterization - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[e0fac] - standard_name = latent_heat_flux_fraction_factor_relative_to_sensible_heat_flux - long_name = latent heat flux fraction factor relative to sensible heat flux for canopy heat storage parameterization - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux - long_name = kinematic surface upward sensible heat flux - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux - long_name = kinematic surface upward latent heat flux - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hflxq] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[evapq] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[hefac] - standard_name = surface_upward_latent_heat_flux_reduction_factor - long_name = surface upward latent heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[hffac] - standard_name = surface_upward_sensible_heat_flux_reduction_factor - long_name = surface upward sensible heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/gcycle.F90_dbg b/physics/debug/gcycle.F90_dbg deleted file mode 100644 index 723580f65..000000000 --- a/physics/debug/gcycle.F90_dbg +++ /dev/null @@ -1,257 +0,0 @@ -!>\file gcycle.F90 -!! This file repopulates specific time-varying surface properties for -!! atmospheric forecast runs. - -module gcycle_mod - - implicit none - - private - - public gcycle - -contains - -!>\ingroup mod_GFS_phys_time_vary -!! This subroutine repopulates specific time-varying surface properties for -!! atmospheric forecast runs. - subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& - frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - xlat_d, xlon_d, slmsk, imap, jmap) -! -! - use machine, only: kind_phys, kind_io8 - implicit none - - integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & - tile_num, nlunit, lsoil, lsoil_lsm, kice - integer, intent(in) :: idate(:), ialb, isot, ivegsrc - character(len=*), intent(in) :: input_nml_file(:) - logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & - min_seaice, min_lakeice, & - xlat_d(:), xlon_d(:) - real(kind=kind_phys), intent(inout) :: smc(:,:), & - slc(:,:), & - stc(:,:), & - smois(:,:), & - sh2o(:,:), & - tslb(:,:), & - tiice(:,:), & - tg3(:), & - tref(:), & - tsfc(:), & - tsfco(:), & - tisfc(:), & - hice(:), & - fice(:), & - facsf(:), & - facwf(:), & - alvsf(:), & - alvwf(:), & - alnsf(:), & - alnwf(:), & - zorli(:), & - zorll(:), & - zorlo(:), & - weasd(:), & - slope(:), & - snoalb(:), & - canopy(:), & - vfrac(:), & - vtype(:), & - stype(:), & - shdmin(:), & - shdmax(:), & - snowd(:), & - cv(:), & - cvb(:), & - cvt(:), & - oro(:), & - oro_uf(:), & - slmsk(:) - - integer, intent(in) :: imap(:), jmap(:) -! -! Local variables -! --------------- - real(kind=kind_phys) :: & -! SLMASK (nx*ny), & - slmskl (nx*ny), & - slmskw (nx*ny), & - TSFFCS (nx*ny), & - ZORFCS (nx*ny), & - AISFCS (nx*ny), & - ALFFC1 (nx*ny*2), & - ALBFC1 (nx*ny*4), & - SMCFC1 (nx*ny*max(lsoil,lsoil_lsm)), & - STCFC1 (nx*ny*max(lsoil,lsoil_lsm)), & - SLCFC1 (nx*ny*max(lsoil,lsoil_lsm)) - - - real (kind=kind_io8) :: min_ice(nx*ny) - character(len=6) :: tile_num_ch - real(kind=kind_phys) :: sig1t, dt_warm - integer :: npts, nb, ix, jx, ls, ios, ll - logical :: exists -! -!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -! -! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' -! *,lonsinpe(0,1) -! - tile_num_ch = " " - if (tile_num < 10) then - write(tile_num_ch, "(a4,i1)") "tile", tile_num - else - write(tile_num_ch, "(a4,i2)") "tile", tile_num - endif -! - sig1t = 0.0_kind_phys - npts = nx*ny -! - if ( nsst > 0 ) then - TSFFCS = tref - else - TSFFCS = tsfco - end if -! - do ix=1,npts - if (lakefrac(ix) > 0.0_kind_phys) then - min_ice(ix) = min_lakeice - else - min_ice(ix) = min_seaice - endif - ZORFCS(ix) = zorll (ix) - IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN - slmskl(ix) = 0.0_kind_phys - slmskw(ix) = 0.0_kind_phys - if (frac_grid) then - slmskw(ix) = floor(landfrac(ix)) - endif - ELSE - slmskl(ix) = 1.0_kind_phys - slmskw(ix) = 1.0_kind_phys - ENDIF - if (nint(slmskl(ix)) == 1 .and. nint(slmskw(ix)) == 0) then - ZORFCS(ix) = zorlo (ix) - endif - IF (fice(ix) >= min_ice(ix)) THEN - AISFCS(ix) = 1.0_kind_phys - ELSE - AISFCS(ix) = 0.0_kind_phys - ENDIF -! - ALFFC1(ix ) = facsf(ix) - ALFFC1(ix + npts ) = facwf(ix) -! - ALBFC1(ix ) = alvsf(ix) - ALBFC1(ix + npts ) = alvwf(ix) - ALBFC1(ix + npts*2) = alnsf(ix) - ALBFC1(ix + npts*3) = alnwf(ix) -! - do ls = 1,max(lsoil,lsoil_lsm) - ll = ix + (ls-1)*npts - if (lsoil == lsoil_lsm) then - SMCFC1(ll) = smc(ix,ls) - STCFC1(ll) = stc(ix,ls) - SLCFC1(ll) = slc(ix,ls) - else - SMCFC1(ll) = smois(ix,ls) - STCFC1(ll) = tslb(ix,ls) - SLCFC1(ll) = sh2o(ix,ls) - endif - enddo - enddo -! -#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, max(lsoil,lsoil_lsm), sig1t, fhcyc, & - idate(4), idate(2), idate(3), idate(1), & - phour, xlat_d, xlon_d, slmskl, slmskw, & - oro, oro_uf, use_ufo, nst_anl, & - hice, fice, tisfc, snowd, slcfc1, & - shdmin, shdmax, slope, snoalb, tsffcs, & - weasd, zorfcs, albfc1, tg3, canopy, & - smcfc1, stcfc1, slmsk, aisfcs, & - vfrac, vtype, stype, alffc1, cv, & - cvb, cvt, me, nthrds, & - nlunit, size(input_nml_file), input_nml_file, & - min_ice, ialb, isot, ivegsrc, & - trim(tile_num_ch), imap, jmap) -#ifndef INTERNAL_FILE_NML - close (Model%nlunit) -#endif -! - if ( nsst > 0 ) then - tref = TSFFCS - else -! tsfc = TSFFCS - tsfco = TSFFCS - endif -! - do ix=1,npts - zorll(ix) = ZORFCS(ix) - if (.not. frac_grid) then - if (slmsk(ix) > 1.9_kind_phys) then - zorli(ix) = ZORFCS(ix) - elseif (slmsk(ix) < 0.1_kind_phys) then - zorlo(ix) = ZORFCS(ix) - endif - else - if (nint(slmskw(ix)) == 0) then - if (fice(ix) >= min_ice(ix)) then - zorli(ix) = ZORFCS(ix) - else - zorlo(ix) = ZORFCS(ix) - endif - endif - endif -! - facsf(ix) = ALFFC1(ix ) - facwf(ix) = ALFFC1(ix + npts ) -! - alvsf(ix) = ALBFC1(ix ) - alvwf(ix) = ALBFC1(ix + npts ) - alnsf(ix) = ALBFC1(ix + npts*2) - alnwf(ix) = ALBFC1(ix + npts*3) -! - do ls = 1,max(lsoil,lsoil_lsm) - ll = ix + (ls-1)*npts - if(lsoil == lsoil_lsm) then - smc(ix,ls) = SMCFC1(ll) - stc(ix,ls) = STCFC1(ll) - slc(ix,ls) = SLCFC1(ll) - else - smois(ix,ls) = SMCFC1(ll) - tslb(ix,ls) = STCFC1(ll) - sh2o(ix,ls) = SLCFC1(ll) - endif - if (ls <= kice) tiice(ix,ls) = STCFC1(ll) - - if (me == 517 .and. ll == 851) write(0,*)' tiice_gcyc=',tiice(ix,ls)& - &,' STCFC1=',STCFc1(ll),' ix=',ix,' ll=',ll - - enddo - enddo -! if (me == 517 .and. ll == 851) write(0,*)' tiic3_gcyc=',tiice(19,:) -! -! if (Model%me .eq. 0) print*,'executed gcycle during hour=',fhour -! - RETURN - END - -end module gcycle_mod diff --git a/physics/debug/sfc_diff.f_dbg b/physics/debug/sfc_diff.f_dbg deleted file mode 100644 index 269a58637..000000000 --- a/physics/debug/sfc_diff.f_dbg +++ /dev/null @@ -1,779 +0,0 @@ -!> \file sfc_diff.f -!! This file contains the surface roughness length formulation based on -!! the surface sublayer scheme in -!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998. - -!> This module contains the CCPP-compliant GFS surface layer scheme. - module sfc_diff - - use machine , only : kind_phys - - implicit none - - public :: sfc_diff_init, sfc_diff_run, sfc_diff_finalize - - private - - real (kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant - - contains - - subroutine sfc_diff_init - end subroutine sfc_diff_init - - subroutine sfc_diff_finalize - end subroutine sfc_diff_finalize - -!> \defgroup GFS_diff_main GFS Surface Layer Scheme Module -!> @{ -!> \brief This subroutine calculates surface roughness length. -!! -!! This subroutine includes the surface roughness length formulation -!! based on the surface sublayer scheme in -!! Zeng and Dickinson (1998) \cite zeng_and_dickinson_1998. -!> \section arg_table_sfc_diff_run Argument Table -!! \htmlinclude sfc_diff_run.html -!! -!> \section general_diff GFS Surface Layer Scheme General Algorithm -!! - Calculate the thermal roughness length formulation over the ocean (see eq. (25) and (26) -!! in Zeng et al. (1998) \cite zeng_et_al_1998). -!! - Calculate Zeng's momentum roughness length formulation over land and sea ice. -!! - Calculate the new vegetation-dependent formulation of thermal roughness length -!! (Zheng et al.(2009) \cite zheng_et_al_2009). -!! Zheng et al. (2009) \cite zheng_et_al_2009 proposed a new formulation on -!! \f$ln(Z_{0m}^,/Z_{0t})\f$ as follows: -!! \f[ -!! ln(Z_{0m}^,/Z_{0t})=(1-GVF)^2C_{zil}k(u*Z_{0g}/\nu)^{0.5} -!! \f] -!! where \f$Z_{0m}^,\f$ is the effective momentum roughness length -!! computed in the following equation for each grid, \f$Z_{0t}\f$ -!! is the roughness lenghth for heat, \f$C_{zil}\f$ is a coefficient -!! (taken as 0.8), k is the Von Karman constant (0.4), -!! \f$\nu=1.5\times10^{-5}m^{2}s^{-1}\f$ is the molecular viscosity, -!! \f$u*\f$ is the friction velocity, and \f$Z_{0g}\f$ is the bare -!! soil roughness length for momentum (taken as 0.01). -!! \n In order to consider the convergence of \f$Z_{0m}\f$ between -!! fully vegetated and bare soil, the effective \f$Z_{0m}^,\f$ is -!! computed: -!! \f[ -!! \ln(Z_{0m}^,)=(1-GVF)^{2}\ln(Z_{0g})+\left[1-(1-GVF)^{2}\right]\ln(Z_{0m}) -!!\f] -!! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes. -!! - subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) - & ps,t1,q1,z1,wind, & !intent(in) - & prsl1,prslki,prsik1,prslk1, & !intent(in) - & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) - & z0pert,ztpert, & ! mg, sfc-perts !intent(in) - & flag_iter,redrag, & !intent(in) - & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) - & wet,dry,icy, & !intent(in) - & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) - & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) - & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) - & lprnt, ipr, kdt, & ! intent(in) - & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) - & z0rl_wav, & !intent(inout) - & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) - & cm_wat, cm_lnd, cm_ice, & !intent(inout) - & ch_wat, ch_lnd, ch_ice, & !intent(inout) - & rb_wat, rb_lnd, rb_ice, & !intent(inout) - & stress_wat,stress_lnd,stress_ice, & !intent(inout) - & fm_wat, fm_lnd, fm_ice, & !intent(inout) - & fh_wat, fh_lnd, fh_ice, & !intent(inout) - & fm10_wat, fm10_lnd, fm10_ice, & !intent(inout) - & fh2_wat, fh2_lnd, fh2_ice, & !intent(inout) - & errmsg, errflg) !intent(out) -! - implicit none -! - integer, parameter :: kp = kind_phys - integer, intent(in) :: im, ivegsrc, kdt, ipr - integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - - integer, dimension(im), intent(in) :: vegtype - - logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) - logical, dimension(im), intent(in) :: flag_iter, wet, dry, icy - logical, intent(in) :: lprnt - - real(kind=kind_phys), dimension(im), intent(in) :: u10m,v10m - real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav - real(kind=kind_phys), dimension(im), intent(in) :: & - & ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & - & wind,sigmaf,shdmax, & - & z0pert,ztpert ! mg, sfc-perts - real(kind=kind_phys), dimension(im), intent(in) :: & - & tskin_wat, tskin_lnd, tskin_ice, & - & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snwdph_wat,snwdph_lnd,snwdph_ice - - real(kind=kind_phys), dimension(im), intent(in) :: z0rl_wav - real(kind=kind_phys), dimension(im), intent(inout) :: & - & z0rl_wat, z0rl_lnd, z0rl_ice, & - & ustar_wat, ustar_lnd, ustar_ice, & - & cm_wat, cm_lnd, cm_ice, & - & ch_wat, ch_lnd, ch_ice, & - & rb_wat, rb_lnd, rb_ice, & - & stress_wat,stress_lnd,stress_ice, & - & fm_wat, fm_lnd, fm_ice, & - & fh_wat, fh_lnd, fh_ice, & - & fm10_wat, fm10_lnd, fm10_ice, & - & fh2_wat, fh2_lnd, fh2_ice - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg -! -! locals -! - integer i -! - real(kind=kind_phys) :: rat, thv1, restar, wind10m, - & czilc, tem1, tem2, virtfac - - real(kind=kind_phys) :: tvs, z0, z0max, ztmax -! - real(kind=kind_phys), parameter :: - & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp - &, charnock=.014_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea - &, zmin=1.0e-6_kp & - &, vis=1.4e-5_kp, rnu=1.51e-5_kp, visi=one/vis & - &, log01=log(0.01_kp), log05=log(0.05_kp), log07=log(0.07_kp) - -! parameter (charnock=.014,ca=.4)!c ca is the von karman constant -! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) -! parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5) - -! real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu -! parameter (aa1=-1.076,bb1=.7045,cc1=-.05808) -! parameter (bb2=-.1954,cc2=.009999) -! parameter (arnu=.135*rnu) -! -! z0s_max=.196e-2 for u10_crit=25 m/s -! z0s_max=.317e-2 for u10_crit=30 m/s -! z0s_max=.479e-2 for u10_crit=35 m/s -! -! mbek -- toga-coare flux algorithm -! parameter (rnu=1.51e-5,arnu=0.11*rnu) - -! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - -! initialize variables. all units are supposedly m.k.s. unless specified -! ps is in pascals, wind is wind speed, -! surface roughness length is converted to m from cm -! - -! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - - do i=1,im - if(flag_iter(i)) then - virtfac = one + rvrdm1 * max(q1(i),qmin) - thv1 = t1(i) * prslki(i) * virtfac - -! compute stability dependent exchange coefficients -! this portion of the code is presently suppressed -! - if (dry(i)) then ! Some land -#ifdef GSD_SURFACE_FLUXES_BUGFIX - tvs = half * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) - & * virtfac -#else - tvs = half * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac -#endif - z0max = max(zmin, min(0.01_kp * z0rl_lnd(i), z1(i))) -!** xubin's new z0 over land - tem1 = one - shdmax(i) - tem2 = tem1 * tem1 - tem1 = one - tem2 - - if( ivegsrc == 1 ) then - - if (vegtype(i) == 10) then - z0max = exp( tem2*log01 + tem1*log07 ) - elseif (vegtype(i) == 6) then - z0max = exp( tem2*log01 + tem1*log05 ) - elseif (vegtype(i) == 7) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01_kp - elseif (vegtype(i) == 16) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01_kp - else - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif - - elseif (ivegsrc == 2 ) then - - if (vegtype(i) == 7) then - z0max = exp( tem2*log01 + tem1*log07 ) - elseif (vegtype(i) == 8) then - z0max = exp( tem2*log01 + tem1*log05 ) - elseif (vegtype(i) == 9) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01_kp - elseif (vegtype(i) == 11) then -! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01_kp - else - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif - - endif -! mg, sfc-perts: add surface perturbations to z0max over land - if (z0pert(i) /= zero ) then - z0max = z0max * (10.0_kp**z0pert(i)) - endif - - z0max = max(z0max, zmin) - -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8_kp - - tem1 = 1.0_kp - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) - - -! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land - if (ztpert(i) /= zero) then - ztmax = ztmax * (10.0_kp**ztpert(i)) - endif - ztmax = max(ztmax, zmin) -! - if(lprnt .and. i == ipr) write(0,*)' z1=',z1(i),' snwdph_lnd=', & - &snwdph_lnd(i),' thv1=',thv1,' wind=',wind(i),' z0max=',z0max, & - &' ztmax=',ztmax,' tvs=',tvs - call stability -! --- inputs: - & (z1(i), snwdph_lnd(i), thv1, wind(i), - & z0max, ztmax, tvs, grav, -! --- outputs: - & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), - & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) - endif ! Dry points - if(lprnt .and. i == ipr) write(0,*)'cm_lnd=',cm_lnd(i),' kdt=',kdt& - &,' ch_lnd=',ch_lnd(i),' ustar_lnd=',ustar_lnd(i) - - if (icy(i)) then ! Some ice - tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac - z0max = max(zmin, min(0.01_kp * z0rl_ice(i), z1(i))) -!** xubin's new z0 over land and sea ice - tem1 = one - shdmax(i) - tem2 = tem1 * tem1 - tem1 = one - tem2 - - if( ivegsrc == 1 ) then - - z0max = exp( tem2*log01 + tem1*log(z0max) ) - elseif (ivegsrc == 2 ) then - z0max = exp( tem2*log01 + tem1*log(z0max) ) - endif - - z0max = max(z0max, zmin) - -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height -! dependance of czil - czilc = 0.8_kp - - tem1 = 1.0_kp - sigmaf(i) - ztmax = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) - ztmax = max(ztmax, 1.0e-6) -! - call stability -! --- inputs: - & (z1(i), snwdph_ice(i), thv1, wind(i), - & z0max, ztmax, tvs, grav, -! --- outputs: - & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), - & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) - endif ! Icy points - -! BWG: Everything from here to end of subroutine was after -! the stuff now put into "stability" - - if (wet(i)) then ! Some open ocean - tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac - z0 = 0.01_kp * z0rl_wat(i) - z0max = max(zmin, min(z0,z1(i))) - ustar_wat(i) = sqrt(grav * z0 / charnock) - wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) - -!** test xubin's new z0 - -! ztmax = z0max - - restar = max(ustar_wat(i)*z0max*visi, 0.000001_kp) - -! restar = log(restar) -! restar = min(restar,5.) -! restar = max(restar,-5.) -! rat = aa1 + (bb1 + cc1*restar) * restar -! rat = rat / (1. + (bb2 + cc2*restar) * restar)) -! rat taken from zeng, zhao and dickinson 1997 - - rat = min(7.0_kp, 2.67_kp * sqrt(sqrt(restar)) - 2.57_kp) - ztmax = max(z0max * exp(-rat), zmin) -! - if (sfc_z0_type == 6) then - call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type == 7) then - call znot_t_v7(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) - else if (sfc_z0_type > 0) then - write(0,*)'no option for sfc_z0_type=',sfc_z0_type - stop - endif -! - call stability -! --- inputs: - & (z1(i), snwdph_wat(i), thv1, wind(i), - & z0max, ztmax, tvs, grav, -! --- outputs: - & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), - & cm_wat(i), ch_wat(i), stress_wat(i), ustar_wat(i)) -! -! update z0 over ocean -! - if (sfc_z0_type >= 0) then - if (sfc_z0_type == 0) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) - -! mbek -- toga-coare flux algorithm -! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) -! new implementation of z0 -! cc = ustar(i) * z0 / rnu -! pp = cc / (1. + cc) -! ff = grav * arnu / (charnock * ustar(i) ** 3) -! z0 = arnu / (ustar(i) * ff ** pp) - - if (redrag) then - z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max), & - & 1.0e-7_kp) - else - z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.e-7_kp) - endif - - elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl_wat(i) = 100.0_kp * z0 ! cm - elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl_wat(i) = 100.0_kp * z0 ! cm - else - z0rl_wat(i) = 1.0e-4_kp - endif - - elseif (z0rl_wav(i) <= 1.0e-7_kp) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) - - if (redrag) then - z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) - else - z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) - endif - endif - - endif ! end of if(open ocean) -! - endif ! end of if(flagiter) loop - enddo - - return - end subroutine sfc_diff_run -!> @} - -!---------------------------------------- -!>\ingroup GFS_diff_main - subroutine stability & -! --- inputs: - & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & -! --- outputs: - & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) -!----- - - integer, parameter :: kp = kind_phys -! --- inputs: - real(kind=kind_phys), intent(in) :: & - & z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav - -! --- outputs: - real(kind=kind_phys), intent(out) :: & - & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar - -! --- locals: - real(kind=kind_phys), parameter :: alpha=5.0_kp, a0=-3.975_kp & - &, a1=12.32_kp, alpha4=4.0_kp*alpha & - &, b1=-7.755_kp, b2=6.041_kp, alpha2=alpha+alpha & - &, beta=1.0_kp & - &, a0p=-7.941_kp, a1p=24.75_kp, b1p=-8.705_kp, b2p=7.899_kp& - &, ztmin1=-999.0_kp, zero=0.0_kp, one=1.0_kp - - real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, - & hl1, hl12, pm, ph, pm10, ph2, - & z1i, - & fms, fhs, hl0, hl0inf, hlinf, - & hl110, hlt, hltinf, olinf, - & tem1, tem2, ztmax1 - - z1i = one / z1 - - tem1 = z0max/z1 - if (abs(one-tem1) > 1.0e-6_kp) then - ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) - else - ztmax1 = 99.0_kp - endif - if( z0max < 0.05_kp .and. snwdph < 10.0_kp ) ztmax1 = 99.0_kp - -! compute stability indices (rb and hlinf) - - dtv = thv1 - tvs - adtv = max(abs(dtv),0.001_kp) - dtv = sign(1.,dtv) * adtv -#ifdef GSD_SURFACE_FLUXES_BUGFIX - rb = max(-5000.0_kp, grav * dtv * z1 - & / (thv1 * wind * wind)) -#else - rb = max(-5000.0_kp, (grav+grav) * dtv * z1 - & / ((thv1 + tvs) * wind * wind)) -#endif - tem1 = one / z0max - tem2 = one / ztmax - fm = log((z0max+z1) * tem1) - fh = log((ztmax+z1) * tem2) - fm10 = log((z0max+10.0_kp) * tem1) - fh2 = log((ztmax+2.0_kp) * tem2) - hlinf = rb * fm * fm / fh - hlinf = min(max(hlinf,ztmin1),ztmax1) -! -! stable case -! - if (dtv >= zero) then - hl1 = hlinf - if(hlinf > 0.25_kp) then - tem1 = hlinf * z1i - hl0inf = z0max * tem1 - hltinf = ztmax * tem1 - aa = sqrt(one + alpha4 * hlinf) - aa0 = sqrt(one + alpha4 * hl0inf) - bb = aa - bb0 = sqrt(one + alpha4 * hltinf) - pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) - ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) - fms = fm - pm - fhs = fh - ph - hl1 = fms * fms * rb / fhs - hl1 = min(max(hl1, ztmin1), ztmax1) - endif -! -! second iteration -! - tem1 = hl1 * z1i - hl0 = z0max * tem1 - hlt = ztmax * tem1 - aa = sqrt(one + alpha4 * hl1) - aa0 = sqrt(one + alpha4 * hl0) - bb = aa - bb0 = sqrt(one + alpha4 * hlt) - pm = aa0 - aa + log( (one+aa)/(one+aa0) ) - ph = bb0 - bb + log( (one+bb)/(one+bb0) ) - hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - aa = sqrt(one + alpha4 * hl110) - pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12,ztmin1),ztmax1) -! aa = sqrt(one + alpha4 * hl12) - bb = sqrt(one + alpha4 * hl12) - ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) -! -! unstable case - check for unphysical obukhov length -! - else ! dtv < 0 case - olinf = z1 / hlinf - tem1 = 50.0_kp * z0max - if(abs(olinf) <= tem1) then - hlinf = -z1 / tem1 - hlinf = min(max(hlinf,ztmin1),ztmax1) - endif -! -! get pm and ph -! - if (hlinf >= -0.5_kp) then - hl1 = hlinf - pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) - ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) - hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) - else ! hlinf < 0.05 - hl1 = -hlinf - tem1 = one / sqrt(hl1) - pm = log(hl1) + 2.0_kp * sqrt(tem1) - .8776_kp - ph = log(hl1) + 0.5_kp * tem1 + 1.386_kp -! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 -! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 - hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp -! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 - hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp -! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 - endif - - endif ! end of if (dtv >= 0 ) then loop -! -! finish the exchange coefficient computation to provide fm and fh -! - fm = fm - pm - fh = fh - ph - fm10 = fm10 - pm10 - fh2 = fh2 - ph2 - cm = ca * ca / (fm * fm) - ch = ca * ca / (fm * fh) - tem1 = 0.00001_kp/z1 - cm = max(cm, tem1) - ch = max(ch, tem1) - stress = cm * wind * wind - ustar = sqrt(stress) - - return -!................................. - end subroutine stability -!--------------------------------- - - -!! add fitted z0,zt curves for hurricane application (used in HWRF/HMON) -!! Weiguo Wang, 2019-0425 - - SUBROUTINE znot_m_v6(uref, znotm) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate areodynamical roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) -! For high winds, try to fit available observational data -! -! Bin Liu, NOAA/NCEP/EMC 2017 -! -! uref(m/s) : wind speed at 10-m height -! znotm(meter): areodynamical roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, - & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, - & p10 = -8.396975715683501e+00, - - & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, - & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, - & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, - - & p35 = 1.840430200185075e-07, p34 = -2.793849676757154e-05, - & p33 = 1.735308193700643e-03, p32 = -6.139315534216305e-02, - & p31 = 1.255457892775006e+00, p30 = -1.663993561652530e+01, - - & p40 = 4.579369142033410e-04 - - - if (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp(p10 + uref * (p11 + uref * (p12 + uref*p13))) - elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35))))) - elseif ( uref > 53.0) then - znotm = p40 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_m_v6 - - SUBROUTINE znot_t_v6(uref, znott) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate scalar roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm -! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF -! -! Bin Liu, NOAA/NCEP/EMC 2017 -! -! uref(m/s) : wind speed at 10-m height -! znott(meter): scalar roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, - & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08, - & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05, - & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04, - - & p25 = -8.654513012535990e-12, p24 = 1.232380050058077e-09, - & p23 = -6.837922749505057e-08, p22 = 1.871407733439947e-06, - & p21 = -2.552246987137160e-05, p20 = 1.428968311457630e-04, - - & p35 = 3.207515102100162e-12, p34 = -2.945761895342535e-10, - & p33 = 8.788972147364181e-09, p32 = -3.814457439412957e-08, - & p31 = -2.448983648874671e-06, p30 = 3.436721779020359e-05, - - & p45 = -3.530687797132211e-11, p44 = 3.939867958963747e-09, - & p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05, - & p41 = 5.988240863928883e-04, p40 = -7.746288511324971e-03, - - & p56 = -1.187982453329086e-13, p55 = 4.801984186231693e-11, - & p54 = -8.049200462388188e-09, p53 = 7.169872601310186e-07, - & p52 = -3.581694433758150e-05, p51 = 9.503919224192534e-04, - & p50 = -1.036679430885215e-02, - - & p60 = 4.751256171799112e-05 - - if (uref >= 0.0 .and. uref < 5.9 ) then - znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 - & + uref * (p14 + uref * p15)))) - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 21.6 .and. uref <= 42.2) then - znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35)))) - elseif ( uref > 42.2 .and. uref <= 53.3) then - znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 - & + uref * (p44 + uref * p45)))) - elseif ( uref > 53.3 .and. uref <= 80.0) then - znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 - & + uref * (p54 + uref * (p55 + uref * p56))))) - elseif ( uref > 80.0) then - znott = p60 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_t_v6 - - - SUBROUTINE znot_m_v7(uref, znotm) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate areodynamical roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Cd-U10 relationship from COARE V3.5 (Edson et al. 2013) -! For high winds, try to fit available observational data -! Comparing to znot_t_v6, slightly decrease Cd for higher wind speed -! -! Bin Liu, NOAA/NCEP/EMC 2018 -! -! uref(m/s) : wind speed at 10-m height -! znotm(meter): areodynamical roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znotm - - real(kind=kind_phys), parameter :: p13 = -1.296521881682694e-02, - & p12 = 2.855780863283819e-01, p11 = -1.597898515251717e+00, - & p10 = -8.396975715683501e+00, - - & p25 = 3.790846746036765e-10, p24 = 3.281964357650687e-09, - & p23 = 1.962282433562894e-07, p22 = -1.240239171056262e-06, - & p21 = 1.739759082358234e-07, p20 = 2.147264020369413e-05, - - & p35 = 1.897534489606422e-07, p34 = -3.019495980684978e-05, - & p33 = 1.931392924987349e-03, p32 = -6.797293095862357e-02, - & p31 = 1.346757797103756e+00, p30 = -1.707846930193362e+01, - - & p40 = 3.371427455376717e-04 - - if (uref >= 0.0 .and. uref <= 6.5 ) then - znotm = exp( p10 + uref * (p11 + uref * (p12 + uref * p13))) - elseif (uref > 6.5 .and. uref <= 15.7) then - znotm = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 15.7 .and. uref <= 53.0) then - znotm = exp( p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35))))) - elseif ( uref > 53.0) then - znotm = p40 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_m_v7 - SUBROUTINE znot_t_v7(uref, znott) - use machine , only : kind_phys - IMPLICIT NONE -! Calculate scalar roughness over water with input 10-m wind -! For low-to-moderate winds, try to match the Ck-U10 relationship from COARE algorithm -! For high winds, try to retain the Ck-U10 relationship of FY2015 HWRF -! To be compatible with the slightly decreased Cd for higher wind speed -! -! Bin Liu, NOAA/NCEP/EMC 2018 -! -! uref(m/s) : wind speed at 10-m height -! znott(meter): scalar roughness scale over water -! - - REAL(kind=kind_phys), INTENT(IN) :: uref - REAL(kind=kind_phys), INTENT(OUT):: znott - - real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, - - & p15 = -9.193764479895316e-10, p14 = 7.052217518653943e-08, - & p13 = -2.163419217747114e-06, p12 = 3.342963077911962e-05, - & p11 = -2.633566691328004e-04, p10 = 8.644979973037803e-04, - - & p25 = -9.402722450219142e-12, p24 = 1.325396583616614e-09, - & p23 = -7.299148051141852e-08, p22 = 1.982901461144764e-06, - & p21 = -2.680293455916390e-05, p20 = 1.484341646128200e-04, - - & p35 = 7.921446674311864e-12, p34 = -1.019028029546602e-09, - & p33 = 5.251986927351103e-08, p32 = -1.337841892062716e-06, - & p31 = 1.659454106237737e-05, p30 = -7.558911792344770e-05, - - & p45 = -2.694370426850801e-10, p44 = 5.817362913967911e-08, - & p43 = -5.000813324746342e-06, p42 = 2.143803523428029e-04, - & p41 = -4.588070983722060e-03, p40 = 3.924356617245624e-02, - - & p56 = -1.663918773476178e-13, p55 = 6.724854483077447e-11, - & p54 = -1.127030176632823e-08, p53 = 1.003683177025925e-06, - & p52 = -5.012618091180904e-05, p51 = 1.329762020689302e-03, - & p50 = -1.450062148367566e-02, p60 = 6.840803042788488e-05 - - if (uref >= 0.0 .and. uref < 5.9 ) then - znott = p00 - elseif (uref >= 5.9 .and. uref <= 15.4) then - znott = p10 + uref * (p11 + uref * (p12 + uref * (p13 - & + uref * (p14 + uref * p15)))) - elseif (uref > 15.4 .and. uref <= 21.6) then - znott = p20 + uref * (p21 + uref * (p22 + uref * (p23 - & + uref * (p24 + uref * p25)))) - elseif (uref > 21.6 .and. uref <= 42.6) then - znott = p30 + uref * (p31 + uref * (p32 + uref * (p33 - & + uref * (p34 + uref * p35)))) - elseif ( uref > 42.6 .and. uref <= 53.0) then - znott = p40 + uref * (p41 + uref * (p42 + uref * (p43 - & + uref * (p44 + uref * p45)))) - elseif ( uref > 53.0 .and. uref <= 80.0) then - znott = p50 + uref * (p51 + uref * (p52 + uref * (p53 - & + uref * (p54 + uref * (p55 + uref * p56))))) - elseif ( uref > 80.0) then - znott = p60 - else - print*, 'Wrong input uref value:',uref - endif - - END SUBROUTINE znot_t_v7 - - -!--------------------------------- - end module sfc_diff diff --git a/physics/debug/sfc_diff.meta_dbg b/physics/debug/sfc_diff.meta_dbg deleted file mode 100644 index 7eda0c7d4..000000000 --- a/physics/debug/sfc_diff.meta_dbg +++ /dev/null @@ -1,653 +0,0 @@ -[ccpp-table-properties] - name = sfc_diff - type = scheme - dependencies = machine.F - -######################################################################## -[ccpp-arg-table] - name = sfc_diff_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[rvrdm1] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[epsm1] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one - long_name = (rd/rv) - 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[grav] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[ps] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[t1] - standard_name = air_temperature_at_lowest_model_layer - long_name = 1st model layer air temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[q1] - standard_name = water_vapor_specific_humidity_at_lowest_model_layer - long_name = 1st model layer specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[z1] - standard_name = height_above_ground_at_lowest_model_layer - long_name = height above ground at 1st model layer - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsl1] - standard_name = air_pressure_at_lowest_model_layer - long_name = Model layer 1 mean pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslki] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsik1] - standard_name = dimensionless_exner_function_at_lowest_model_interface - long_name = dimensionless Exner function at the ground surface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslk1] - standard_name = dimensionless_exner_function_at_lowest_model_layer - long_name = dimensionless Exner function at the lowest model layer - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[shdmax] - standard_name = maximum_vegetation_area_fraction - long_name = max fractnl cover of green veg - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ivegsrc] - standard_name = vegetation_type_dataset_choice - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[z0pert] - standard_name = perturbation_of_momentum_roughness_length - long_name = perturbation of momentum roughness length - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ztpert] - standard_name = perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = perturbation of heat to momentum roughness length ratio - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[redrag] - standard_name = flag_for_reduced_drag_coefficient_over_sea - long_name = flag for reduced drag coefficient over sea - units = flag - dimensions = () - type = logical - intent = in - optional = F -[u10m] - standard_name = x_wind_at_10m - long_name = 10 meter u wind speed - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[v10m] - standard_name = y_wind_at_10m - long_name = 10 meter v wind speed - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sfc_z0_type] - standard_name = flag_for_surface_roughness_option_over_ocean - long_name = surface roughness options over ocean - units = flag - dimensions = () - type = integer - intent = in - optional = F -[wet] - standard_name = flag_nonzero_wet_surface_fraction - long_name = flag indicating presence of some ocean or lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[dry] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[icy] - standard_name = flag_nonzero_sea_ice_surface_fraction - long_name = flag indicating presence of some sea ice surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[tskin_wat] - standard_name = surface_skin_temperature_over_ocean_interstitial - long_name = surface skin temperature over ocean (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tskin_lnd] - standard_name = surface_skin_temperature_over_land_interstitial - long_name = surface skin temperature over land (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tskin_ice] - standard_name = surface_skin_temperature_over_ice_interstitial - long_name = surface skin temperature over ice (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf_wat] - standard_name = surface_skin_temperature_after_iteration_over_ocean - long_name = surface skin temperature after iteration over ocean - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf_lnd] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsurf_ice] - standard_name = surface_skin_temperature_after_iteration_over_ice - long_name = surface skin temperature after iteration over ice - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_wat] - standard_name = surface_snow_thickness_water_equivalent_over_ocean - long_name = water equivalent snow depth over ocean - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_ice] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[z0rl_wat] - standard_name = surface_roughness_length_over_ocean_interstitial - long_name = surface roughness length over ocean (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[z0rl_lnd] - standard_name = surface_roughness_length_over_land_interstitial - long_name = surface roughness length over land (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[z0rl_ice] - standard_name = surface_roughness_length_over_ice_interstitial - long_name = surface roughness length over ice (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[z0rl_wav] - standard_name = surface_roughness_length_from_wave_model - long_name = surface roughness length from wave model - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ustar_wat] - standard_name = surface_friction_velocity_over_ocean - long_name = surface friction velocity over ocean - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ustar_lnd] - standard_name = surface_friction_velocity_over_land - long_name = surface friction velocity over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ustar_ice] - standard_name = surface_friction_velocity_over_ice - long_name = surface friction velocity over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cm_wat] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean - long_name = surface exchange coeff for momentum over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cm_lnd] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_land - long_name = surface exchange coeff for momentum over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cm_ice] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice - long_name = surface exchange coeff for momentum over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ch_wat] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean - long_name = surface exchange coeff heat & moisture over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ch_lnd] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land - long_name = surface exchange coeff heat & moisture over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ch_ice] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice - long_name = surface exchange coeff heat & moisture over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rb_wat] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ocean - long_name = bulk Richardson number at the surface over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rb_lnd] - standard_name = bulk_richardson_number_at_lowest_model_level_over_land - long_name = bulk Richardson number at the surface over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[rb_ice] - standard_name = bulk_richardson_number_at_lowest_model_level_over_ice - long_name = bulk Richardson number at the surface over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[stress_wat] - standard_name = surface_wind_stress_over_ocean - long_name = surface wind stress over ocean - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[stress_lnd] - standard_name = surface_wind_stress_over_land - long_name = surface wind stress over land - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[stress_ice] - standard_name = surface_wind_stress_over_ice - long_name = surface wind stress over ice - units = m2 s-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean - long_name = Monin-Obukhov similarity function for momentum over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm_lnd] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_land - long_name = Monin-Obukhov similarity function for momentum over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ice - long_name = Monin-Obukhov similarity function for momentum over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean - long_name = Monin-Obukhov similarity function for heat over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh_lnd] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_land - long_name = Monin-Obukhov similarity function for heat over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_over_ice - long_name = Monin-Obukhov similarity function for heat over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm10_wat] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm10_lnd] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land - long_name = Monin-Obukhov similarity parameter for momentum at 10m over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fm10_ice] - standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice - long_name = Monin-Obukhov similarity parameter for momentum at 10m over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh2_wat] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean - long_name = Monin-Obukhov similarity parameter for heat at 2m over ocean - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh2_lnd] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_land - long_name = Monin-Obukhov similarity parameter for heat at 2m over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fh2_ice] - standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice - long_name = Monin-Obukhov similarity parameter for heat at 2m over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/sfc_drv.f_dbg b/physics/debug/sfc_drv.f_dbg deleted file mode 100644 index 3c4a937db..000000000 --- a/physics/debug/sfc_drv.f_dbg +++ /dev/null @@ -1,666 +0,0 @@ -!> \file sfc_drv.f -!! This file contains the Noah land surface scheme driver. - -!> This module contains the CCPP-compliant Noah land surface scheme driver. - module lsm_noah - - use machine, only: kind_phys - use set_soilveg_mod, only: set_soilveg - use namelist_soilveg - - implicit none - - private - - public :: lsm_noah_init, lsm_noah_run, lsm_noah_finalize - - contains - -!>\ingroup Noah_LSM -!! This subroutine contains the CCPP-compliant lsm_noah_init to initialize soil vegetation. -!! \section arg_table_lsm_noah_init Argument Table -!! \htmlinclude lsm_noah_init.html -!! - subroutine lsm_noah_init(me, isot, ivegsrc, nlunit, - & pores, resid, errmsg, errflg) - - implicit none - - integer, intent(in) :: me, isot, ivegsrc, nlunit - - real (kind=kind_phys), dimension(:), intent(out) :: pores, resid - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (ivegsrc > 2) then - errmsg = 'The NOAH LSM expects that the ivegsrc physics '// - & 'namelist parameter is 0, 1, or 2. Exiting...' - errflg = 1 - return - end if - if (isot > 1) then - errmsg = 'The NOAH LSM expects that the isot physics '// - & 'namelist parameter is 0, or 1. Exiting...' - errflg = 1 - return - end if - - !--- initialize soil vegetation - call set_soilveg(me, isot, ivegsrc, nlunit) - - pores (:) = maxsmc (:) - resid (:) = drysmc (:) - - end subroutine lsm_noah_init - - -!! \section arg_table_lsm_noah_finalize Argument Table -!! \htmlinclude lsm_noah_finalize.html -!! - subroutine lsm_noah_finalize(errmsg, errflg) - - implicit none - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine lsm_noah_finalize - - -! ===================================================================== ! -! description: ! -! ! -! usage: ! -! ! -! call sfc_drv ! -! --- inputs: ! -! ( im, km, ps, t1, q1, soiltyp, vegtype, sigmaf, ! -! sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, ! -! prsl1, prslki, zf, land, wind, slopetyp, ! -! shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, ! -! lheatstrg, isot, ivegsrc, ! -! --- in/outs: ! -! weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, ! -! canopy, trans, tsurf, zorl, ! -! --- outputs: ! -! sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, ! -! cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, ! -! smcwlt2, smcref2, wet1 ) ! -! ! -! ! -! subprogram called: sflx ! -! ! -! program history log: ! -! xxxx -- created ! -! 200x -- sarah lu modified ! -! oct 2006 -- h. wei modified ! -! apr 2009 -- y.-t. hou modified to include surface emissivity ! -! effect on lw radiation. replaced the comfussing ! -! slrad (net sw + dlw) with sfc net sw snet=dsw-usw ! -! sep 2009 -- s. moorthi modification to remove rcl and unit change! -! nov 2011 -- sarah lu corrected wet1 calculation -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! im - integer, horiz dimention and num of used pts 1 ! -! km - integer, vertical soil layer dimension 1 ! -! ps - real, surface pressure (pa) im ! -! t1 - real, surface layer mean temperature (k) im ! -! q1 - real, surface layer mean specific humidity im ! -! soiltyp - integer, soil type (integer index) im ! -! vegtype - integer, vegetation type (integer index) im ! -! sigmaf - real, areal fractional cover of green vegetation im ! -! sfcemis - real, sfc lw emissivity ( fraction ) im ! -! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! -! dswflx - real, total sky sfc downward sw flux ( w/m**2 ) im ! -! snet - real, total sky sfc netsw flx into ground(w/m**2) im ! -! delt - real, time interval (second) 1 ! -! tg3 - real, deep soil temperature (k) im ! -! cm - real, surface exchange coeff for momentum (m/s) im ! -! ch - real, surface exchange coeff heat & moisture(m/s) im ! -! prsl1 - real, sfc layer 1 mean pressure (pa) im ! -! prslki - real, dimensionless exner function at layer 1 im ! -! zf - real, height of bottom layer (m) im ! -! land - logical, = T if a point with any land im ! -! wind - real, wind speed (m/s) im ! -! slopetyp - integer, class of sfc slope (integer index) im ! -! shdmin - real, min fractional coverage of green veg im ! -! shdmax - real, max fractnl cover of green veg (not used) im ! -! snoalb - real, upper bound on max albedo over deep snow im ! -! sfalb - real, mean sfc diffused sw albedo (fractional) im ! -! flag_iter- logical, im ! -! flag_guess-logical, im ! -! lheatstrg- logical, flag for canopy heat storage 1 ! -! parameterization ! -! isot - integer, sfc soil type data source zobler or statsgo ! -! ivegsrc - integer, sfc veg type data source umd or igbp ! -! ! -! input/outputs: ! -! weasd - real, water equivalent accumulated snow depth (mm) im ! -! 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 ! -! smc - real, total soil moisture content (fractional) im,km ! -! stc - real, soil temp (k) im,km ! -! slc - real, liquid soil moisture im,km ! -! canopy - real, canopy moisture content (m) im ! -! trans - real, total plant transpiration (m/s) im ! -! tsurf - real, surface skin temperature (after iteration) im ! -! zorl - real, surface roughness im ! -! sncovr1 - real, snow cover over land (fractional) im ! -! qsurf - real, specific humidity at sfc im ! -! gflux - real, soil heat flux (w/m**2) im ! -! drain - real, subsurface runoff (mm/s) im ! -! evap - real, evaperation from latent heat flux im ! -! hflx - real, sensible heat flux im ! -! ep - real, potential evaporation im ! -! runoff - real, surface runoff (m/s) im ! -! cmm - real, im ! -! chh - real, im ! -! evbs - real, direct soil evaporation (m/s) im ! -! evcw - real, canopy water evaporation (m/s) im ! -! sbsno - real, sublimation/deposit from snopack (m/s) im ! -! snowc - real, fractional snow cover im ! -! stm - real, total soil column moisture content (m) im ! -! snohf - real, snow/freezing-rain latent heat flux (w/m**2)im ! -! smcwlt2 - real, dry soil moisture threshold im ! -! smcref2 - real, soil moisture threshold im ! -! wet1 - real, normalized soil wetness im ! -! ! -! ==================== end of description ===================== ! - -!>\defgroup Noah_LSM GFS Noah LSM Model -!! \brief This is Noah LSM driver module, with the functionality of -!! preparing variables to run Noah LSM gfssflx(), calling Noah LSM and post-processing -!! variables for return to the parent model suite including unit conversion, as well -!! as diagnotics calculation. -!! \section arg_table_lsm_noah_run Argument Table -!! \htmlinclude lsm_noah_run.html -!! -!> \section general_noah_drv GFS sfc_drv General Algorithm -!> @{ - subroutine lsm_noah_run & - & ( im, km, grav, cp, hvap, rd, eps, epsm1, rvrdm1, ps, & ! --- inputs: - & t1, q1, soiltyp, vegtype, sigmaf, & - & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & - & prsl1, prslki, zf, land, wind, slopetyp, & - & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & - & lheatstrg, isot, ivegsrc, & - & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne - & lprnt, ipr, kdt, & -! --- in/outs: - & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf, zorl, & -! --- outputs: - & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & - & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, errmsg, errflg & - & ) -! - !use machine , only : kind_phys - use funcphys, only : fpvs - - use surface_perturbation, only : ppfbet - - implicit none - -! --- constant parameters: - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys - real(kind=kind_phys), parameter :: one = 1.0_kind_phys - real(kind=kind_phys), parameter :: rhoh2o = 1000.0_kind_phys - real(kind=kind_phys), parameter :: a2 = 17.2693882_kind_phys - real(kind=kind_phys), parameter :: a3 = 273.16_kind_phys - real(kind=kind_phys), parameter :: a4 = 35.86_kind_phys - real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) - real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys - - real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1_kind_phys, -0.4_kind_phys, & - & -1.0_kind_phys, -2.0_kind_phys / - -! --- input: - logical, intent(in) :: lprnt - integer, intent(in) :: im, km, isot, ivegsrc, ipr, kdt - real (kind=kind_phys), intent(in) :: grav, cp, hvap, rd, eps, & - & epsm1, rvrdm1 - real (kind=kind_phys), intent(in) :: pertvegf - - integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp - - real (kind=kind_phys), dimension(im), intent(in) :: ps, & - & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & - & ch, prsl1, prslki, wind, shdmin, shdmax, & - & snoalb, sfalb, zf, & - & bexppert, xlaipert, vegfpert - - real (kind=kind_phys), intent(in) :: delt - - logical, dimension(im), intent(in) :: flag_iter, flag_guess, land - - logical, intent(in) :: lheatstrg - -! --- in/out: - real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & - & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl - - real (kind=kind_phys), dimension(im,km), intent(inout) :: & - & smc, stc, slc - -! --- output: - real (kind=kind_phys), dimension(im), intent(inout) :: sncovr1, & - & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & - & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, & - & wet1 - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals: - real (kind=kind_phys), dimension(im) :: rch, rho, & - & q0, qs1, theta1, weasd_old, snwdph_old, & - & tprcp_old, srflag_old, tskin_old, canopy_old - - real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & - & smsoil, slsoil - - real (kind=kind_phys), dimension(im,km) :: zsoil, smc_old, & - & stc_old, slc_old - - real (kind=kind_phys) :: alb, albedo, beta, chx, cmx, cmc, & - & dew, drip, dqsdt2, ec, edir, ett, eta, esnow, etp, & - & flx1, flx2, flx3, ffrozp, lwdn, pc, prcp, ptu, q2, & - & q2sat, solnet, rc, rcs, rct, rcq, rcsoil, rsmin, & - & runoff1, runoff2, runoff3, sfcspd, sfcprs, sfctmp, & - & sfcems, sheat, shdfac, shdmin1d, shdmax1d, smcwlt, & - & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & - & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, tbot, & - & xlai, zlvl, swdn, tem, z0, bexpp, xlaip, vegfp, & - & mv, sv, alphav, betav, vegftmp, cpinv, hvapi, elocp - - integer :: couple, ice, nsoil, nroot, slope, stype, vtype - integer :: i, k, iflag -! -!===> ... begin here -! - cpinv = one/cp - hvapi = one/hvap - elocp = hvap/cp - -!> - Initialize CCPP error handling variables - - errmsg = '' - errflg = 0 - -!> - Save land-related prognostic fields for guess run. - - if (lprnt) write(0,*)' tkin at beg of sfc_drv ', tskin(ipr), & - &' kdt=',kdt,' land=',land(ipr),' flag_guess=',flag_guess(ipr) - do i = 1, im - if (land(i) .and. flag_guess(i)) then - weasd_old(i) = weasd(i) - snwdph_old(i) = snwdph(i) - tskin_old(i) = tskin(i) - canopy_old(i) = canopy(i) - tprcp_old(i) = tprcp(i) - srflag_old(i) = srflag(i) - - do k = 1, km - smc_old(i,k) = smc(i,k) - stc_old(i,k) = stc(i,k) - slc_old(i,k) = slc(i,k) - enddo - endif ! land & flag_guess - enddo - -! --- ... initialization block - - do i = 1, im - if (flag_iter(i) .and. land(i)) then - ep(i) = zero - evap (i) = zero - hflx (i) = zero - gflux(i) = zero - drain(i) = zero - canopy(i) = max(canopy(i), zero) - - evbs (i) = zero - evcw (i) = zero - trans(i) = zero - sbsno(i) = zero - snowc(i) = zero - snohf(i) = zero - -!> - initialize variables wind, q, and rh at level 1. - - q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) - theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) - - rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0(i))) - qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) - qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) - q0 (i) = min(qs1(i), q0(i)) - - do k = 1, km - zsoil(i,k) = zsoil_noah(k) - enddo - -!> - Prepare variables to run Noah LSM: -!! - 1. configuration information (c): -! couple couple-uncouple flag (=1: coupled, =0: uncoupled) -! ffrozp flag for snow-rain detection (1.=snow, 0.=rain) -! ice sea-ice flag (=1: sea-ice, =0: land) -! dt timestep (sec) (dt should not exceed 3600 secs) = delt -! zlvl height (\f$m\f$) above ground of atmospheric forcing variables -! nsoil number of soil layers (at least 2) -! sldpth the thickness of each soil layer (\f$m\f$) - - couple = 1 ! run noah lsm in 'couple' mode -! use srflag directly to allow fractional rain/snow -! if (srflag(i) == 1.0) then ! snow phase -! ffrozp = 1.0 -! elseif (srflag(i) == 0.0) then ! rain phase -! ffrozp = 0.0 -! endif - ffrozp = srflag(i) - ice = 0 - - zlvl = zf(i) - - nsoil = km - sldpth(1) = - zsoil(i,1) - do k = 2, km - sldpth(k) = zsoil(i,k-1) - zsoil(i,k) - enddo - -!> - 2. forcing data (f): -! lwdn lw dw radiation flux (\f$W m^{-2}\f$) -! solnet - net sw radiation flux (dn-up) (\f$W m^{-2}\f$) -! sfcprs - pressure at height zlvl above ground (pascals) -! prcp - precip rate (\f$kg m^{-2} s^{-1}\f$) -! sfctmp - air temperature (\f$K\f$) at height zlvl above ground -! th2 - air potential temperature (\f$K\f$) at height zlvl above ground -! q2 - mixing ratio at height zlvl above ground (\f$kg kg^{-1}\f$) - - lwdn = dlwflx(i) !..downward lw flux at sfc in w/m2 - swdn = dswsfc(i) !..downward sw flux at sfc in w/m2 - solnet = snet(i) !..net sw rad flx (dn-up) at sfc in w/m2 - sfcems = sfcemis(i) - - sfcprs = prsl1(i) - prcp = rhoh2o * tprcp(i) / delt - sfctmp = t1(i) - th2 = theta1(i) - q2 = q0(i) - -!> - 3. other forcing (input) data (i): -! sfcspd - wind speed (\f$m s^{-1}\f$) at height zlvl above ground -! q2sat - sat mixing ratio at height zlvl above ground (\f$kg kg^{-1}\f$) -! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (\f$kg kg^{-1} k^{-1}\f$) - - sfcspd = wind(i) - q2sat = qs1(i) - dqsdt2 = q2sat * a23m4/(sfctmp-a4)**2 - -!> - 4. canopy/soil characteristics (s): -! vegtyp - vegetation type (integer index) -> vtype -! soiltyp - soil type (integer index) -> stype -! slopetyp- class of sfc slope (integer index) -> slope -! shdfac - areal fractional coverage of green vegetation (0.0-1.0) -! shdmin - minimum areal fractional coverage of green vegetation -> shdmin1d -! ptu - photo thermal unit (plant phenology for annuals/crops) -! alb - backround snow-free surface albedo (fraction) -! snoalb - upper bound on maximum albedo over deep snow -> snoalb1d -! tbot - bottom soil temperature (local yearly-mean sfc air temp) - - vtype = vegtype(i) - stype = soiltyp(i) - slope = slopetyp(i) - shdfac= sigmaf(i) - -!> - Call surface_perturbation::ppfbet() to perturb vegetation fraction that goes into gsflx(). -! perturb vegetation fraction that goes into sflx, use the same -! perturbation strategy as for albedo (percentile matching) -!! Following Gehne et al. (2018) \cite gehne_et_al_2018, a perturbation of vegetation -!! fraction is added to account for the uncertainty. A percentile matching technique -!! is applied to guarantee the perturbed vegetation fraction is bounded between 0 and -!! 1. The standard deviation of the perturbations is 0.25 for vegetation fraction of -!! 0.5 and the perturbations go to zero as vegetation fraction approaches its upper -!! or lower bound. - vegfp = vegfpert(i) ! sfc-perts, mgehne - if (pertvegf>zero) then - ! compute beta distribution parameters for vegetation fraction - mv = shdfac - sv = pertvegf*mv*(one-mv) - alphav = mv*mv*(one-mv)/(sv*sv)-mv - betav = alphav*(one-mv)/mv - ! compute beta distribution value corresponding - ! to the given percentile albPpert to use as new albedo - call ppfbet(vegfp,alphav,betav,iflag,vegftmp) - shdfac = vegftmp - endif -! *** sfc-perts, mgehne - - shdmin1d = shdmin(i) - shdmax1d = shdmax(i) - snoalb1d = snoalb(i) - - ptu = zero - alb = sfalb(i) - tbot = tg3(i) - -!> - 5. history (state) variables (h): -! cmc - canopy moisture content (\f$m\f$) -! t1 - ground/canopy/snowpack effective skin temperature (\f$K\f$) -> tsea -! stc(nsoil) - soil temp (\f$K\f$) -> stsoil -! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil -! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil -! snowh - actual snow depth (\f$m\f$) -! sneqv - liquid water-equivalent snow depth (\f$m\f$) -! albedo - surface albedo including snow effect (unitless fraction) -! ch - surface exchange coefficient for heat and moisture (\f$m s^{-1}\f$) -> chx -! cm - surface exchange coefficient for momentum (\f$m s^{-1}\f$) -> cmx -! z0 - surface roughness (\f$m\f$) -> zorl(\f$cm\f$) - - cmc = canopy(i) * 0.001_kind_phys ! convert from mm to m - tsea = tsurf(i) ! clu_q2m_iter - - do k = 1, km - stsoil(k) = stc(i,k) - smsoil(k) = smc(i,k) - slsoil(k) = slc(i,k) - enddo - - snowh = snwdph(i) * 0.001_kind_phys ! convert from mm to m - sneqv = weasd(i) * 0.001_kind_phys ! convert from mm to m - if (sneqv /= zero .and. snowh == zero) then - snowh = 10.0_kind_phys * sneqv - endif - - chx = ch(i) * wind(i) ! compute conductance - cmx = cm(i) * wind(i) - chh(i) = chx * rho(i) - cmm(i) = cmx - -! ---- ... outside sflx, roughness uses cm as unit - z0 = zorl(i) * 0.01_kind_phys -! ---- mgehne, sfc-perts -! - Apply perturbation of soil type b parameter and leave area index. - bexpp = bexppert(i) ! sfc perts, mgehne - xlaip = xlaipert(i) ! sfc perts, mgehne - - if (lprnt .and. i == ipr) write(0,*)' ch=',ch(i),' cm=',cm(i), & - &' wind=',wind(i),' rho=',rho(i),' z0=',z0,' swdn=',swdn, & - &' solnet=',solnet,' lwdn=',lwdn,' sfcems=',sfcems,' sfctmp=', & - &sfctmp,' prcp=',prcp,' th2=',th2,' q2=',q2,' iveegsrc=',ivegsrc, & - &'vtype=',vtype,' stype=',stype - - -!> - Call Noah LSM gfssflx(). - - call gfssflx & ! ccppdox: these is sflx in mpbl -! --- inputs: - & ( nsoil, couple, ice, ffrozp, delt, zlvl, sldpth, & - & swdn, solnet, lwdn, sfcems, sfcprs, sfctmp, & - & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & - & vtype, stype, slope, shdmin1d, alb, snoalb1d, & - & bexpp, xlaip, & ! sfc-perts, mgehne - & lheatstrg, & -! --- input/outputs: - & tbot, cmc, tsea, stsoil, smsoil, slsoil, sneqv, chx, cmx, & - & z0, & -! --- outputs: - & nroot, shdfac, snowh, albedo, eta, sheat, ec, & - & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & - & flx1, flx2, flx3, runoff1, runoff2, runoff3, & - & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & - & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) - -!> - Noah LSM: prepare variables for return to parent model and unit conversion. -!> - 6. output (o): -!!\n eta - actual latent heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n sheat - sensible heat flux (\f$W m^{-2}\f$: positive, if upward from sfc) -!!\n beta - ratio of actual/potential evap (dimensionless) -!!\n etp - potential evaporation (\f$W m^{-2}\f$) -!!\n ssoil - soil heat flux (\f$W m^{-2}\f$: negative if downward from surface) -!!\n runoff1 - surface runoff (\f$m s^{-1}\f$), not infiltrating the surface -!!\n runoff2 - subsurface runoff (\f$m s^{-1}\f$), drainage out bottom - - evap(i) = eta - hflx(i) = sheat - gflux(i) = ssoil - - evbs(i) = edir - evcw(i) = ec - trans(i) = ett - sbsno(i) = esnow - snowc(i) = sncovr - stm(i) = soilm * 1000.0_kind_phys ! unit conversion (from m to kg m-2) - snohf(i) = flx1 + flx2 + flx3 - - smcwlt2(i) = smcwlt - smcref2(i) = smcref - - ep(i) = etp - tsurf(i) = tsea - - do k = 1, km - stc(i,k) = stsoil(k) - smc(i,k) = smsoil(k) - slc(i,k) = slsoil(k) - enddo - wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) - -! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) - runoff(i) = runoff1 * 1000.0_kind_phys - drain (i) = runoff2 * 1000.0_kind_phys - -! --- ... unit conversion (from m to mm) - canopy(i) = cmc * 1000.0_kind_phys - snwdph(i) = snowh * 1000.0_kind_phys - weasd(i) = sneqv * 1000.0_kind_phys - sncovr1(i) = sncovr -! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) - zorl(i) = z0*100.0_kind_phys - -!> - Do not return the following output fields to parent model: -!!\n ec - canopy water evaporation (m s-1) -!!\n edir - direct soil evaporation (m s-1) -!!\n et(nsoil)-plant transpiration from a particular root layer (m s-1) -!!\n ett - total plant transpiration (m s-1) -!!\n esnow - sublimation from (or deposition to if <0) snowpack (m s-1) -!!\n drip - through-fall of precip and/or dew in excess of canopy -!! water-holding capacity (m) -!!\n dew - dewfall (or frostfall for t<273.15) (m) -!!\n beta - ratio of actual/potential evap (dimensionless) -!!\n flx1 - precip-snow sfc (w m-2) -!!\n flx2 - freezing rain latent heat flux (w m-2) -!!\n flx3 - phase-change heat flux from snowmelt (w m-2) -!!\n snomlt - snow melt (m) (water equivalent) -!!\n sncovr - fractional snow cover (unitless fraction, 0-1) -!!\n runoff3 - numerical trunctation in excess of porosity (smcmax) -!! for a given soil layer at the end of a time step -!!\n rc - canopy resistance (s m-1) -!!\n pc - plant coefficient (unitless fraction, 0-1) where pc*etp -!! = actual transp -!!\n xlai - leaf area index (dimensionless) -!!\n rsmin - minimum canopy resistance (s m-1) -!!\n rcs - incoming solar rc factor (dimensionless) -!!\n rct - air temperature rc factor (dimensionless) -!!\n rcq - atmos vapor pressure deficit rc factor (dimensionless) -!!\n rcsoil - soil moisture rc factor (dimensionless) -!!\n soilw - available soil moisture in root zone (unitless fraction -!! between smcwlt and smcmax) -!!\n soilm - total soil column moisture content (frozen+unfrozen) (m) -!!\n smcwlt - wilting point (volumetric) -!!\n smcdry - dry soil moisture threshold where direct evap frm top -!! layer ends (volumetric) -!!\n smcref - soil moisture threshold where transpiration begins to -!! stress (volumetric) -!!\n smcmax - porosity, i.e. saturated value of soil moisture -!! (volumetric) -!!\n nroot - number of root layers, a function of veg type, determined -!! in subroutine redprm. - -! endif ! end if flag_iter and flag -! enddo ! end do_i_loop - -!> - Compute specific humidity at surface (\a qsurf). - - rch(i) = rho(i) * cp * ch(i) * wind(i) - qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) - -!> - Compute surface upward sensible heat flux (\a hflx) and evaporation -!! flux (\a evap). - tem = one / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - - endif ! flag_iter & land - enddo - - if (lprnt) then - write(0,*)' in noah hflx=',hflx(ipr),' evap=',evap(ipr) - write(0,*)' tsurf=',tsurf(ipr),' tskin_old=',tskin_old(ipr) - endif - -!> - Restore land-related prognostic fields for guess run. - - do i = 1, im - if (land(i)) then - if (flag_guess(i)) then - weasd(i) = weasd_old(i) - snwdph(i) = snwdph_old(i) - tskin(i) = tskin_old(i) - canopy(i) = canopy_old(i) - tprcp(i) = tprcp_old(i) - srflag(i) = srflag_old(i) - - do k = 1, km - smc(i,k) = smc_old(i,k) - stc(i,k) = stc_old(i,k) - slc(i,k) = slc_old(i,k) - enddo - else ! flag_guess = F - tskin(i) = tsurf(i) - endif ! flag_guess - endif ! land - enddo -! - return -!................................... - end subroutine lsm_noah_run -!----------------------------- -!> @} - - end module lsm_noah diff --git a/physics/debug/sfc_drv.meta_dbg b/physics/debug/sfc_drv.meta_dbg deleted file mode 100644 index 7b400d762..000000000 --- a/physics/debug/sfc_drv.meta_dbg +++ /dev/null @@ -1,788 +0,0 @@ -[ccpp-table-properties] - name = lsm_noah - type = scheme - dependencies = funcphys.f90,machine.F,set_soilveg.f,sflx.f,surface_perturbation.F90 - -######################################################################## -[ccpp-arg-table] - name = lsm_noah_init - type = scheme -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[isot] - standard_name = soil_type_dataset_choice - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[ivegsrc] - standard_name = vegetation_type_dataset_choice - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[nlunit] - standard_name = iounit_namelist - long_name = fortran unit number for file opens - units = none - dimensions = () - type = integer - intent = in - optional = F -[pores] - standard_name = maximum_soil_moisture_content_for_land_surface_model - long_name = maximum soil moisture for a given soil type for land surface model - units = m - dimensions = (30) - type = real - intent = out - kind = kind_phys -[resid] - standard_name = minimum_soil_moisture_content_for_land_surface_model - long_name = minimum soil moisture for a given soil type for land surface model - units = m - dimensions = (30) - type = real - intent = out - kind = kind_phys -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-arg-table] - name = lsm_noah_finalize - type = scheme -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F - -######################################################################## -[ccpp-arg-table] - name = lsm_noah_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[km] - standard_name = soil_vertical_dimension - long_name = soil vertical layer dimension - units = count - dimensions = () - type = integer - intent = in - optional = F -[grav] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rd] - standard_name = gas_constant_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[epsm1] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one - long_name = (rd/rv) - 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rvrdm1] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[ps] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[t1] - standard_name = air_temperature_at_lowest_model_layer - long_name = 1st model layer air temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[q1] - standard_name = water_vapor_specific_humidity_at_lowest_model_layer - long_name = 1st model layer specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[soiltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[sigmaf] - standard_name = bounded_vegetation_area_fraction - long_name = areal fractional cover of green vegetation bounded on the bottom - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sfcemis] - standard_name = surface_longwave_emissivity_over_land_interstitial - long_name = surface lw emissivity in fraction over land (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_land - long_name = total sky surface downward longwave flux absorbed by the ground over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[dswsfc] - standard_name = surface_downwelling_shortwave_flux - long_name = total sky surface downward shortwave flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snet] - standard_name = surface_net_downwelling_shortwave_flux - long_name = total sky surface net shortwave flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[delt] - standard_name = time_step_for_dynamics - long_name = dynamics time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[tg3] - standard_name = deep_soil_temperature - long_name = bottom soil temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cm] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_land - long_name = surface exchange coeff for momentum over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ch] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_land - long_name = surface exchange coeff heat & moisture over land - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsl1] - standard_name = air_pressure_at_lowest_model_layer - long_name = Model layer 1 mean pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslki] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[zf] - standard_name = height_above_ground_at_lowest_model_layer - long_name = height above ground at 1st model layer - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[land] - standard_name = flag_nonzero_land_surface_fraction - long_name = flag indicating presence of some land surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[slopetyp] - standard_name = surface_slope_classification - long_name = surface slope type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[shdmin] - standard_name = minimum_vegetation_area_fraction - long_name = min fractional coverage of green veg - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[shdmax] - standard_name = maximum_vegetation_area_fraction - long_name = max fractnl cover of green veg (not used) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snoalb] - standard_name = upper_bound_on_max_albedo_over_deep_snow - long_name = upper bound on max albedo over deep snow - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sfalb] - standard_name = surface_diffused_shortwave_albedo - long_name = mean surface diffused shortwave albedo - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[flag_guess] - standard_name = flag_for_guess_run - long_name = flag for guess run - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[lheatstrg] - standard_name = flag_for_canopy_heat_storage - long_name = flag for canopy heat storage parameterization - units = flag - dimensions = () - type = logical - intent = in - optional = F -[isot] - standard_name = soil_type_dataset_choice - long_name = soil type dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[ivegsrc] - standard_name = vegetation_type_dataset_choice - long_name = land use dataset choice - units = index - dimensions = () - type = integer - intent = in - optional = F -[bexppert] - standard_name = perturbation_of_soil_type_b_parameter - long_name = perturbation of soil type "b" parameter - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[xlaipert] - standard_name = perturbation_of_leaf_area_index - long_name = perturbation of leaf area index - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[vegfpert] - standard_name = perturbation_of_vegetation_fraction - long_name = perturbation of vegetation fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[pertvegf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[kdt] - standard_name = index_of_time_step - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in - optional = F -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_land - long_name = water equiv of acc snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snwdph] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tskin] - standard_name = surface_skin_temperature_over_land_interstitial - long_name = surface skin temperature over land (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_land - long_name = total precipitation amount in each time step over land - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[srflag] - standard_name = flag_for_precipitation_type - long_name = flag for snow or rain precipitation - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[smc] - standard_name = volume_fraction_of_soil_moisture - long_name = volumetric fraction of soil moisture - units = frac - dimensions = (horizontal_loop_extent,soil_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[stc] - standard_name = soil_temperature - long_name = soil temperature - units = K - dimensions = (horizontal_loop_extent,soil_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[slc] - standard_name = volume_fraction_of_unfrozen_soil_moisture - long_name = volume fraction of unfrozen soil moisture - units = frac - dimensions = (horizontal_loop_extent,soil_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[canopy] - standard_name = canopy_water_amount - long_name = canopy moisture content - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[trans] - standard_name = transpiration_flux - long_name = total plant transpiration rate - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tsurf] - standard_name = surface_skin_temperature_after_iteration_over_land - long_name = surface skin temperature after iteration over land - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[zorl] - standard_name = surface_roughness_length_over_land_interstitial - long_name = surface roughness length over land (temporary use as interstitial) - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[sncovr1] - standard_name = surface_snow_area_fraction_over_land - long_name = surface snow area fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qsurf] - standard_name = surface_specific_humidity_over_land - long_name = surface air saturation specific humidity over land - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gflux] - standard_name = upward_heat_flux_in_soil_over_land - long_name = soil heat flux over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[drain] - standard_name = subsurface_runoff_flux - long_name = subsurface runoff flux - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux_over_land - long_name = kinematic surface upward latent heat flux over land - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_land - long_name = kinematic surface upward sensible heat flux over land - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[ep] - standard_name = surface_upward_potential_latent_heat_flux_over_land - long_name = surface upward potential latent heat flux over land - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[runoff] - standard_name = surface_runoff_flux - long_name = surface runoff flux - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cmm] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land - long_name = momentum exchange coefficient over land - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[chh] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land - long_name = thermal exchange coefficient over land - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evbs] - standard_name = soil_upward_latent_heat_flux - long_name = soil upward latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evcw] - standard_name = canopy_upward_latent_heat_flux - long_name = canopy upward latent heat flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[sbsno] - standard_name = snow_deposition_sublimation_upward_latent_heat_flux - long_name = latent heat flux from snow depo/subl - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowc] - standard_name = surface_snow_area_fraction - long_name = surface snow area fraction - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[stm] - standard_name = soil_moisture_content - long_name = soil moisture content - units = kg m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snohf] - standard_name = snow_freezing_rain_upward_latent_heat_flux - long_name = latent heat flux due to snow and frz rain - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[smcwlt2] - standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point - long_name = soil water fraction at wilting point - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[smcref2] - standard_name = threshold_volume_fraction_of_condensed_water_in_soil - long_name = soil moisture threshold - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[wet1] - standard_name = normalized_soil_wetness - long_name = normalized soil wetness - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/sfc_sice.f_dbg b/physics/debug/sfc_sice.f_dbg deleted file mode 100644 index ccaa8d9d7..000000000 --- a/physics/debug/sfc_sice.f_dbg +++ /dev/null @@ -1,772 +0,0 @@ -!> \file sfc_sice.f -!! This file contains the GFS three level thermodynamic sea ice model. - -!> This module contains the CCPP-compliant GFS sea ice scheme. - module sfc_sice - - contains - - subroutine sfc_sice_init() - end subroutine sfc_sice_init -! - subroutine sfc_sice_finalize() - end subroutine sfc_sice_finalize - -!>\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 -!! \htmlinclude sfc_sice_run.html -!! -!> \section general_sice_run GFS Sea Ice Driver General Algorithm -!!The model has four prognostic variables: the snow layer thickness \f$h_s\f$, the ice layer thickness -!! \f$h_i\f$, the upper and lower ice layer temperatures located at the midpoints of the layers -!! \f$h_i/4\f$ and \f$3h_i/4\f$ below the ice surface, respectively \f$T_1\f$ and \f$T_2\f$. The temperature of -!! the bottom of the ice is fixed at \f$T_f\f$, the freezing temperature of seawater. The temperature of -!! the top of the ice or snow, \f$T_s\f$, is determined from the surface energy balance. -!! The model consists of a zero-heat-capacity snow layer overlying two equally thick sea ice layers (Figure 1). -!! The upper ice layer has a variable heat capacity to represent brine pockets. -!! \image html GFS_sice_wonton2000_fig1.png "Fig.1 Schematic representation of the three-layer model" width=5cm -!! The ice model main program ice3lay() performs two functions: -!! - \b Calculation \b of \b ice \b temperature -!!\n The surface temperature is determined from the diagnostic balance between -!! the upward conduction of heat through snow and/or ice and upward flux of heat -!! from the surface. -!! - \b Calculation \b of \b ice \b and \b snow \b changes -!!\n In addition to calculating ice temperature changes, the ice model must -!! also readjust the sizes of the snow and ice layers 1) to accommodate -!! mass fluxes at the upper and lower surfaces, 2) to convert snow below -!! the water line to ice, and 3) to equalize the thickness of the two -!! ice layers. -!> \section detailed_sice_run GFS Sea Ice Driver Detailed Algorithm -!> @{ - subroutine sfc_sice_run & - & ( im, kice, sbc, hvap, tgice, cp, eps, epsm1, rvrdm1, grav, & ! --- inputs: - & t0c, rd, ps, t1, q1, delt, & - & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & - & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, lprnt, ipr, me, & - & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: - & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & - & islmsk_cice, & -! & islmsk_cice, min_lakeice, min_seaice, oceanfrac, & - & xlon_d, xlat_d, & - & errmsg, errflg - & ) - -! ===================================================================== ! -! description: ! -! ! -! usage: ! -! ! -! call sfc_sice ! -! inputs: ! -! ( im, kice, ps, t1, q1, delt, ! -! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! -! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! -! flag_iter, ! -! input/outputs: ! -! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! -! outputs: ! -! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! -! ! -! subprogram called: ice3lay. ! -! ! -!> program history log: -!!- 2005 -- xingren wu created from original progtm and added -!! two-layer ice model -!!- 200x -- sarah lu added flag_iter -!!- oct 2006 -- h. wei added cmm and chh to output -!!- 2007 -- x. wu modified for mom4 coupling (i.e. cpldice) -!! (not used anymore) -!!- 2007 -- s. moorthi micellaneous changes -!!- may 2009 -- y.-t. hou modified to include surface emissivity -!! effect on lw radiation. replaced the confusing -!! slrad with sfc net sw sfcnsw (dn-up). reformatted -!! the code and add program documentation block. -!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and -!! further optimized -!!- jan 2015 -- x. wu change "cimin = 0.15" for both -!! uncoupled and coupled case -! ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: size ! -! im, kice - integer, horiz dimension and num of ice layers 1 ! -! ps - real, surface pressure im ! -! t1 - real, surface layer mean temperature ( k ) im ! -! q1 - real, surface layer mean specific humidity im ! -! delt - real, time interval (second) 1 ! -! sfcemis - real, sfc lw emissivity ( fraction ) im ! -! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! -! sfcnsw - real, total sky sfc netsw flx into ground(w/m**2) im ! -! sfcdsw - real, total sky sfc downward sw flux ( w/m**2 ) im ! -! srflag - real, snow/rain fraction for precipitation im ! -! cm - real, surface exchange coeff for momentum (m/s) im ! -! ch - real, surface exchange coeff heat & moisture(m/s) im ! -! prsl1 - real, surface layer mean pressure im ! -! prslki - real, im ! -! prsik1 - real, im ! -! prslk1 - real, im ! -! islimsk - integer, sea/land/ice mask (=0/1/2) im ! -! wind - real, im ! -! flag_iter- logical, im ! -! ! -! input/outputs: ! -! hice - real, sea-ice thickness im ! -! fice - real, sea-ice concentration im ! -! tice - real, sea-ice surface temperature im ! -! weasd - real, water equivalent accumulated snow depth (mm)im ! -! tskin - real, ground surface skin temperature ( k ) im ! -! tprcp - real, total precipitation im ! -! tiice - real, temperature of ice internal (k) im,kice ! -! ep - real, potential evaporation im ! -! ! -! outputs: ! -! snwdph - real, water equivalent snow depth (mm) im ! -! qsurf - real, specific humidity at sfc im ! -! snowmt - real, snow melt (m) im ! -! gflux - real, soil heat flux (w/m**2) im ! -! cmm - real, surface exchange coeff for momentum (m/s) im ! -! chh - real, surface exchange coeff heat&moisture (m/s) im ! -! evap - real, evaperation from latent heat flux im ! -! hflx - real, sensible heat flux im ! -! ! -! ===================================================================== ! -! - use machine, only : kind_phys - use funcphys, only : fpvs -! - implicit none -! -! - Define constant parameters - integer, parameter :: kmi = 2 !< 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - real(kind=kind_phys), parameter :: himax = 8.0_kind_phys !< maximum ice thickness allowed - real(kind=kind_phys), parameter :: himin = 0.1_kind_phys !< minimum ice thickness required - real(kind=kind_phys), parameter :: hsmax = 2.0_kind_phys !< maximum snow depth allowed - real(kind=kind_phys), parameter :: timin = 173.0_kind_phys !< minimum temperature allowed for snow/ice - real(kind=kind_phys), parameter :: albfw = 0.06_kind_phys !< albedo for lead - real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys - real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys - -! --- inputs: - integer, intent(in) :: im, kice, ipr, me - logical, intent(in) :: lprnt - - real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & - & epsm1, grav, rvrdm1, t0c, rd - - real (kind=kind_phys), dimension(im), intent(in) :: ps, & - & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind - &, xlon_d, xlat_d -! & prsl1, prslki, prsik1, prslk1, wind, oceanfrac - -! integer, dimension(im), intent(in) :: islimsk - integer, dimension(im), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt -! real (kind=kind_phys), intent(in) :: delt, min_seaice, & -! & min_lakeice - - logical, dimension(im), intent(in) :: flag_iter - -! --- input/outputs: - real (kind=kind_phys), dimension(im), intent(inout) :: hice, & - & fice, tice, weasd, tskin, tprcp, ep - - real (kind=kind_phys), dimension(im,kice), intent(inout) :: tiice - -! --- outputs: - real (kind=kind_phys), dimension(im), intent(inout) :: snwdph, & - & qsurf, snowmt, gflux, cmm, chh, evap, hflx - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals: - real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & - & sneti, hfd, hfi, & -! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & - & focn, snof, rch, rho, & - & snowd, theta1 - - real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) - &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw -! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin - - integer :: i, k - - logical :: flag(im) -! -!===> ... begin here -! - cpinv = one/cp - hvapi = one/hvap - elocp = hvap/cp - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (lprnt) write(0,*)' in sfc_sice tiice=',tiice(ipr,:) -! -!> - Set flag for sea-ice. - - do i = 1, im - flag(i) = (islmsk_cice(i) == 2) .and. flag_iter(i) -! if (flag_iter(i) .and. islmsk_cice(i) < 2) then -! hice(i) = zero -! fice(i) = zero -! endif - enddo - - do i = 1, im - if (flag(i)) then - if (srflag(i) > zero) then - ep(i) = ep(i)*(one-srflag(i)) - weasd(i) = weasd(i) + 1000.0_kind_phys*tprcp(i)*srflag(i) - tprcp(i) = tprcp(i)*(one-srflag(i)) - endif - endif - enddo -! --- ... update sea ice temperature - - do k = 1, kice - do i = 1, im - if (flag(i)) then - stsice(i,k) = tiice(i,k) - endif - enddo - enddo - if (lprnt) write(0,*)' stsice=',stsice(ipr,:),' flag=',flag(ipr) - -! --- ... initialize variables. all units are supposedly m.k.s. unless specifie -! psurf is in pascals, wind is wind speed, theta1 is adiabatic surface -! temp from level 1, rho is density, qs1 is sat. hum. at level1 and qss -! is sat. hum. at surface -! convert slrad to the civilized unit from langley minute-1 k-4 - - do i = 1, im - if (flag(i)) then -! if (oceanfrac(i) > zero) then -! cimin = min_seaice -! else -! cimin = min_lakeice -! endif -! psurf(i) = 1000.0 * ps(i) -! ps1(i) = 1000.0 * prsl1(i) - -! dlwflx has been given a negative sign for downward longwave -! sfcnsw is the net shortwave flux (direction: dn-up) - - q0 = max(q1(i), qmin) -! tsurf(i) = tskin(i) -#ifdef GSD_SURFACE_FLUXES_BUGFIX - theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer -#else - theta1(i) = t1(i) * prslki(i) -#endif - rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) - qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) - q0 = min(qs1, q0) - -! if (fice(i) < cimin) then -! print *,'warning: ice fraction is low:', fice(i) -! fice(i) = cimin -! tice(i) = tgice -! tskin(i)= tgice -! print *,'fix ice fraction: reset it to:', fice(i) -! endif - ffw(i) = one - fice(i) - - qssi = fpvs(tice(i)) - qssi = eps*qssi / (ps(i) + epsm1*qssi) - qssw = fpvs(tgice) - qssw = eps*qssw / (ps(i) + epsm1*qssw) - -!> - Convert snow depth in water equivalent from mm to m unit. - - snowd(i) = weasd(i) * 0.001_kind_phys -! flagsnw(i) = .false. - -! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and -! soil is allowed to interact with the atmosphere. -! we should eventually move to a linear combination of soil and -! snow under the condition of patchy snow. - -! --- ... rcp = rho cp ch v - - cmm(i) = cm(i) * wind(i) - chh(i) = rho(i) * ch(i) * wind(i) - rch(i) = chh(i) * cp - -!> - Calculate sensible and latent heat flux over open water & sea ice. - - evapi(i) = elocp * rch(i) * (qssi - q0) - evapw(i) = elocp * rch(i) * (qssw - q0) -! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) - - snetw = sfcdsw(i) * (one - albfw) - snetw = min(3.0_kind_phys*sfcnsw(i) & - & / (one+2.0_kind_phys*ffw(i)), snetw) -!> - Calculate net solar incoming at top \a sneti. - sneti(i) = (sfcnsw(i) - ffw(i)*snetw) / fice(i) - - t12 = tice(i) * tice(i) - t14 = t12 * t12 - -!> - Calculate net non-solar and upir heat flux @ ice surface \a hfi. - -#ifdef GSD_SURFACE_FLUXES_BUGFIX - hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & - & + rch(i)*(tice(i)/prsik1(i) - theta1(i)) -#else - hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & - & + rch(i)*(tice(i) - theta1(i)) -#endif -!> - Calculate heat flux derivative at surface \a hfd. - hfd(i) = 4.0_kind_phys*sfcemis(i)*sbc*tice(i)*t12 & - & + (one + elocp*eps*hvap*qs1/(rd*t12)) * rch(i) - - t12 = tgice * tgice - t14 = t12 * t12 - -! --- ... hfw = net heat flux @ water surface (within ice) - -! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & -! & + rch(i)*(tgice - theta1(i)) - snetw - -!> - Assigin heat flux from ocean \a focn and snowfall rate as constants, which -!! should be from ocean model and other physics. - focn(i) = 2.0_kind_phys ! heat flux from ocean - should be from ocn model - snof(i) = zero ! snowfall rate - snow accumulates in gbphys - -!> - Initialize snow depth \a snowd. - hice(i) = max( min( hice(i), himax ), himin ) - snowd(i) = min( snowd(i), hsmax ) - - if (snowd(i) > (2.0_kind_phys*hice(i))) then -! print *, 'warning: too much snow :',snowd(i) - snowd(i) = hice(i) + hice(i) -! print *,'fix: decrease snow depth to:',snowd(i) - endif - endif - enddo - -!> - Call the three-layer thermodynamics sea ice model ice3lay(). - call ice3lay -! --- inputs: ! - & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! - & lprnt, ipr, -! --- outputs: ! - & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! - - do i = 1, im - if (flag(i)) then - if (tice(i) < timin) then - print *,'warning: snow/ice temperature is too low:',tice(i) - &, ' i=',i,' me=',me - tice(i) = timin - print *,'fix snow/ice temperature: reset it to:',tice(i) - endif - - if (stsice(i,1) < timin) then - write(0,*)'warning: layer 1 ice temp is too low:',stsice(i,1) - &, ' i=',i,' me=',me - &,' xlon_d=',xlon_d(i),' xlat_d=',xlat_d(i) - stsice(i,1) = timin - print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) - endif - - if (stsice(i,2) < timin) then - print *,'warning: layer 2 ice temp is too low:',stsice(i,2) - stsice(i,2) = timin - print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) - endif - - endif - enddo - - do k = 1, kice - do i = 1, im - if (flag(i)) then - tiice(i,k) = min(stsice(i,k), t0c) - endif - enddo - enddo - - do i = 1, im - if (flag(i)) then -! --- ... calculate sensible heat flux (& evap over sea ice) - -#ifdef GSD_SURFACE_FLUXES_BUGFIX - hflxi = rch(i) * (tice(i)/prsik1(i) - theta1(i)) - hflxw = rch(i) * (tgice / prsik1(i) - theta1(i)) -#else - hflxi = rch(i) * (tice(i) - theta1(i)) - hflxw = rch(i) * (tgice - theta1(i)) -#endif - hflx(i) = fice(i)*hflxi + ffw(i)*hflxw - evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) - tskin(i) = fice(i)*tice(i) + ffw(i)*tgice -! -! --- ... the rest of the output - - qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) - -! --- ... convert snow depth back to mm of water equivalent - - weasd(i) = snowd(i) * 1000.0_kind_phys - snwdph(i) = weasd(i) * dsi ! snow depth in mm - - tem = one / rho(i) - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi - endif - enddo -! - return -!! @} - -! ================= - contains -! ================= - - -!----------------------------------- -!> This subroutine is the entity of three-layer sea ice vertical thermodynamics -!! based on Winton(2000) \cite winton_2000 . -!!\ingroup gfs_sice_main -!\param[in] im integer, horizontal dimension -!\param[in] kmi integer, number of ice layers (2) -!\param[in] fice real, sea-ice concentration -!\param[in] flag logical, ice mask flag -!\param[in] hfi real, net non-solar and heat flux at surface (\f$W/m^2\f$) -!\param[in] hfd real, heat flux derivative at surface -!\param[in] sneti real, net solar incoming at top (\f$W/m^2\f$) -!\param[in] focn real, heat flux from ocean (\f$W/m^2\f$) -!\param[in] delt real, time step(\f$sec\f$) -!\param[in,out] snowd real, snow depth -!\param[in,out] hice real, sea-ice thickness -!\param[in,out] stsice real, temperature at mid-point of ice levels (\f$^oC\f$) -!\param[in,out] tice real, surface temperature (\f$^oC\f$) -!\param[in,out] snof real, snowfall rate (\f$ms^{-1}\f$) -!\param[out] snowmt real, snow melt during delt (\f$m\f$) -!\param[out] gflux real, conductive heat flux (\f$W/m^2\f$) -!>\section gen_ice3lay Three-layer Thermodynamics Sea Ice Model General Algorithm -!> @{ - subroutine ice3lay -!................................... -! --- inputs: - & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, & - & lprnt, ipr, -! --- input/outputs: - & snowd, hice, stsice, tice, snof, & -! --- outputs: - & snowmt, gflux & - & ) - -!************************************************************************** -! * -! three-layer sea ice vertical thermodynamics * -! * -! based on: m. winton, "a reformulated three-layer sea ice model", * -! journal of atmospheric and oceanic technology, 2000 * -! * -! * -! -> +---------+ <- tice - diagnostic surface temperature ( <= 0c )* -! / | | * -! snowd | snow | <- 0-heat capacity snow layer * -! \ | | * -! => +---------+ * -! / | | * -! / | | <- t1 - upper 1/2 ice temperature; this layer has * -! / | | a variable (t/s dependent) heat capacity * -! hice |...ice...| * -! \ | | * -! \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity) * -! \ | | * -! -> +---------+ <- base of ice fixed at seawater freezing temp. * -! * -! ===================== defination of variables ===================== ! -! ! -! inputs: size ! -! im, kmi - integer, horiz dimension and num of ice layers 1 ! -! fice - real, sea-ice concentration im ! -! flag - logical, ice mask flag 1 ! -! hfi - real, net non-solar and heat flux @ surface(w/m^2) im ! -! hfd - real, heat flux derivatice @ sfc (w/m^2/deg-c) im ! -! sneti - real, net solar incoming at top (w/m^2) im ! -! focn - real, heat flux from ocean (w/m^2) im ! -! delt - real, timestep (sec) 1 ! -! ! -! input/outputs: ! -! snowd - real, surface pressure im ! -! hice - real, sea-ice thickness im ! -! stsice - real, temp @ midpt of ice levels (deg c) im,kmi! -! tice - real, surface temperature (deg c) im ! -! snof - real, snowfall rate (m/sec) im ! -! ! -! outputs: ! -! snowmt - real, snow melt during delt (m) im ! -! gflux - real, conductive heat flux (w/m^2) im ! -! ! -! locals: ! -! hdi - real, ice-water interface (m) ! -! hsni - real, snow-ice (m) ! -! ! -! ======================================================================= ! -! - -! --- constant parameters: (properties of ice, snow, and seawater) - real (kind=kind_phys), parameter :: ds = 330.0_kind_phys !< snow (ov sea ice) density (kg/m^3) - real (kind=kind_phys), parameter :: dw =1000.0_kind_phys !< fresh water density (kg/m^3) - real (kind=kind_phys), parameter :: dsdw = ds/dw - real (kind=kind_phys), parameter :: dwds = dw/ds - real (kind=kind_phys), parameter :: ks = 0.31_kind_phys !< conductivity of snow (w/mk) - real (kind=kind_phys), parameter :: i0 = 0.3_kind_phys !< ice surface penetrating solar fraction - real (kind=kind_phys), parameter :: ki = 2.03_kind_phys !< conductivity of ice (w/mk) - real (kind=kind_phys), parameter :: di = 917.0_kind_phys !< density of ice (kg/m^3) - real (kind=kind_phys), parameter :: didw = di/dw - real (kind=kind_phys), parameter :: dsdi = ds/di - real (kind=kind_phys), parameter :: ci = 2054.0_kind_phys !< heat capacity of fresh ice (j/kg/k) - real (kind=kind_phys), parameter :: li = 3.34e5_kind_phys !< latent heat of fusion (j/kg-ice) - real (kind=kind_phys), parameter :: si = 1.0_kind_phys !< salinity of sea ice - real (kind=kind_phys), parameter :: mu = 0.054_kind_phys !< relates freezing temp to salinity - real (kind=kind_phys), parameter :: tfi = -mu*si !< sea ice freezing temp = -mu*salinity - real (kind=kind_phys), parameter :: tfw = -1.8_kind_phys !< tfw - seawater freezing temp (c) - real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001_kind_phys - real (kind=kind_phys), parameter :: dici = di*ci - real (kind=kind_phys), parameter :: dili = di*li - real (kind=kind_phys), parameter :: dsli = ds*li - real (kind=kind_phys), parameter :: ki4 = ki*4.0_kind_phys - real (kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - -! --- inputs: - integer, intent(in) :: im, kmi, ipr - logical :: lprnt - - real (kind=kind_phys), dimension(im), intent(in) :: fice, hfi, & - & hfd, sneti, focn - - real (kind=kind_phys), intent(in) :: delt - - logical, dimension(im), intent(in) :: flag - -! --- input/outputs: - real (kind=kind_phys), dimension(im), intent(inout) :: snowd, & - & hice, tice, snof - - real (kind=kind_phys), dimension(im,kmi), intent(inout) :: stsice - -! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: snowmt, & - & gflux - -! --- locals: - - real (kind=kind_phys) :: dt2, dt4, dt6, h1, h2, dh, wrk, wrk1, & - & dt2i, hdi, hsni, ai, bi, a1, b1, a10, b10& - &, c1, ip, k12, k32, tsf, f1, tmelt, bmelt - - integer :: i -! -!===> ... begin here -! - dt2 = delt + delt - dt4 = dt2 + dt2 - dt6 = dt2 + dt4 - dt2i = one / dt2 - - do i = 1, im - if (flag(i)) then - snowd(i) = snowd(i) * dwds - hdi = (dsdw*snowd(i) + didw*hice(i)) - - if (hice(i) < hdi) then - snowd(i) = snowd(i) + hice(i) - hdi - hsni = (hdi - hice(i)) * dsdi - hice (i) = hice(i) + hsni - endif - - snof(i) = snof(i) * dwds - tice(i) = tice(i) - t0c ! convert from K to C - stsice(i,1) = min(stsice(i,1)-t0c, tfi0) ! degc - stsice(i,2) = min(stsice(i,2)-t0c, tfi0) ! degc - - if (lprnt .and. i == ipr) write(0,*)' in ice3stsice=',stsice(i,:),& - &' snowd=',snowd(i) - ip = i0 * sneti(i) ! ip +v (in winton ip=-i0*sneti as sol -v) - if (snowd(i) > zero) then - tsf = zero - ip = zero - else - tsf = tfi - ip = i0 * sneti(i) ! ip +v here (in winton ip=-i0*sneti) - endif - tice(i) = min(tice(i), tsf) - -!> - Ice temperature calculation. - - bi = hfd(i) - ai = hfi(i) - sneti(i) + ip - tice(i)*bi ! +v sol input here -!> - Calculate the effective conductive coupling of the snow-ice layer -!! between the surface and the upper layer ice temperature \f$h_i/4\f$ -!! beneath the snow-ice interface (see \a eq.(5) in Winton (2000) \cite winton_2000). - k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) - -!> - Calculate the conductive coupling between the two ice temperature -!! points (see \a eq.(10) in Winton (2000) \cite winton_2000). - k32 = (ki+ki) / hice(i) - - wrk = one / (dt6*k32 + dici*hice(i)) - a10 = dici*hice(i)*dt2i + k32*(dt4*k32 + dici*hice(i))*wrk - b10 = -di*hice(i) * (ci*stsice(i,1) + li*tfi/stsice(i,1)) & - & * dt2i - ip & - & - k32*(dt4*k32*tfw + dici*hice(i)*stsice(i,2)) * wrk - - wrk1 = k12 / (k12 + bi) - a1 = a10 + bi * wrk1 - b1 = b10 + ai * wrk1 - c1 = dili * tfi * dt2i * hice(i) - -!> - Calculate the new upper ice temperature following \a eq.(21) -!! in Winton (2000) \cite winton_2000. - stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1)/(a1+a1) - tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) - - if (lprnt .and. i == ipr) write(0,*)' ice3stsice1=',stsice(i,1), & - &' hice=',hice(i),' sneti=',sneti(i),' abc=',a1,b1,c1,' k12=',k12 - -!> - If the surface temperature is greater than the freezing temperature -!! of snow (when there is snow over) or sea ice (when there is none), the -!! surface temperature is fixed at the melting temperature of snow or sea -!! ice, respectively, and the upper ice temperature is recomputed from -!! \a eq.(21) using the coefficients given by \a eqs. (19),(20), and (18). An energy flux -!! \a eq.(22) is applied toward surface melting thereby balancing the surface -!! energy budget. - if (tice(i) > tsf) then - a1 = a10 + k12 - b1 = b10 - k12*tsf - stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1) & - & / (a1+a1) - tice(i) = tsf - tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt - else - tmelt =zero - snowd(i) = snowd(i) + snof(i)*delt - endif -!> - Calculate the new lower ice temperature following \a eq.(15) -!! in Winton (2000) \cite winton_2000. - stsice(i,2) = (dt2*k32*(stsice(i,1) + tfw + tfw) & - & + dici*hice(i)*stsice(i,2)) * wrk - -!> - Calculate the energy for bottom melting (or freezing, if negative) -!! following \a eq.(23), which serves to balance the difference between -!! the oceanic heat flux to the ice bottom and the conductive flux of -!! heat upward from the bottom. - bmelt = (focn(i) + ki4*(stsice(i,2) - tfw)/hice(i)) * delt - -!> - Calculation of ice and snow mass changes. - - h1 = 0.5_kind_phys * hice(i) - h2 = 0.5_kind_phys * hice(i) - - if (lprnt .and. i == ipr) write(0,*)' hi2ice=',h1,h2,hice(i) -!> - Calculate the top layer thickness. - - if (tmelt <= snowd(i)*dsli) then - snowmt(i) = tmelt / dsli - snowd (i) = snowd(i) - snowmt(i) - else - snowmt(i) = snowd(i) - h1 = max(zero, h1 - (tmelt - snowd(i)*dsli) & - & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1)))) - snowd(i) = zero - endif - -! --- ... and bottom -!> - When the energy for bottem melting \f$M_b\f$ is negative (i.e., freezing -!! is happening),calculate the bottom layer thickness \f$h_2\f$ and the new -!! lower layer temperature (see \a eqs.(24)-(26)). - if (bmelt < zero) then - dh = -bmelt / (dili + dici*(tfi - tfw)) - stsice(i,2) = (h2*stsice(i,2) + dh*tfw) / (h2 + dh) - h2 = h2 + dh - else - h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) - endif - h2 = max(h2,zero) - -!> - If ice remains, even up 2 layers, else, pass negative energy back in snow. -!! Calculate the new upper layer temperature (see \a eq.(38)). - - hice(i) = h1 + h2 - - if (lprnt .and. i == ipr) & - & write(0,*)' h12=',h1,h2,' hice=',hice(ipr) - - if (hice(i) > zero) then - if (h1 > 0.5_kind_phys*hice(i)) then - f1 = one - (h2+h2) / hice(i) - stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& - & + (one - f1)*stsice(i,2) - - if (stsice(i,2) > tfi) then - hice(i) = hice(i) - h2*ci*(stsice(i,2) - tfi)/ (li*delt) - stsice(i,2) = tfi - endif - else - f1 = (h1+h1) / hice(i) - if (lprnt .and. i == ipr) write(0,*)' stsb=',stsice(i,1),' f1=', & - &f1,' sts2=',stsice(i,2),' litfifac=',li*tfi/(ci*stsice(i,1)) - stsice(i,1) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& - & + (one - f1)*stsice(i,2) - if (lprnt .and. i == ipr) write(0,*)' stsa=',stsice(i,1),' tfi=', & - &tfi,'li=',li,' ci=',ci,' tice=',tice(i) - stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & - & - 4.0_kind_phys*tfi*li/ci)) * 0.5_kind_phys - endif - - k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) - gflux(i) = k12 * (stsice(i,1) - tice(i)) - else - snowd(i) = snowd(i) + (h1*(ci*(stsice(i,1) - tfi) & - & - li*(one - tfi/stsice(i,1))) & - & + h2*(ci*(stsice(i,2) - tfi) - li)) / li - - hice(i) = max(zero, snowd(i)*dsdi) - snowd(i) = zero - stsice(i,1) = tfw - stsice(i,2) = tfw - gflux(i) = zero - endif ! end if_hice_block - - gflux(i) = fice(i) * gflux(i) - snowmt(i) = snowmt(i) * dsdw - snowd(i) = snowd(i) * dsdw - tice(i) = tice(i) + t0c - stsice(i,1) = stsice(i,1) + t0c - stsice(i,2) = stsice(i,2) + t0c - endif ! end if_flag_block - enddo ! end do_i_loop - - if (lprnt) write(0,*)' ice3endstsice=',stsice(ipr,:) - return -!................................... - end subroutine ice3lay -!> @} -!----------------------------------- - -! =========================== ! -! end contain programs ! -! =========================== ! - -!................................... - end subroutine sfc_sice_run -!----------------------------------- -!> @} - end module sfc_sice diff --git a/physics/debug/sfc_sice.meta_dbg b/physics/debug/sfc_sice.meta_dbg deleted file mode 100644 index e8143dcc5..000000000 --- a/physics/debug/sfc_sice.meta_dbg +++ /dev/null @@ -1,478 +0,0 @@ -[ccpp-table-properties] - name = sfc_sice - type = scheme - dependencies = funcphys.f90,machine.F - -######################################################################## -[ccpp-arg-table] - name = sfc_sice_run - type = scheme -[im] - standard_name = horizontal_loop_extent - long_name = horizontal loop extent - units = count - dimensions = () - type = integer - intent = in - optional = F -[kice] - standard_name = ice_vertical_dimension - long_name = vertical loop extent for ice levels, start at 1 - units = count - dimensions = () - type = integer - intent = in - optional = F -[sbc] - standard_name = stefan_boltzmann_constant - long_name = Stefan-Boltzmann constant - units = W m-2 K-4 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[tgice] - standard_name = freezing_point_temperature_of_seawater - long_name = freezing point temperature of seawater - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[eps] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants - long_name = rd/rv - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[epsm1] - standard_name = ratio_of_dry_air_to_water_vapor_gas_constants_minus_one - long_name = (rd/rv) - 1 - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rvrdm1] - standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one - long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) - units = none - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[grav] - standard_name = gravitational_acceleration - long_name = gravitational acceleration - units = m s-2 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[t0c] - standard_name = temperature_at_zero_celsius - long_name = temperature at 0 degree Celsius - units = K - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[rd] - standard_name = gas_constant_dry_air - long_name = ideal gas constant for dry air - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[ps] - standard_name = surface_air_pressure - long_name = surface pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[t1] - standard_name = air_temperature_at_lowest_model_layer - long_name = surface layer mean temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[q1] - standard_name = water_vapor_specific_humidity_at_lowest_model_layer - long_name = surface layer mean specific humidity - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[delt] - standard_name = time_step_for_dynamics - long_name = time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[sfcemis] - standard_name = surface_longwave_emissivity_over_ice_interstitial - long_name = surface lw emissivity in fraction over ice (temporary use as interstitial) - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[dlwflx] - standard_name = surface_downwelling_longwave_flux_absorbed_by_ground_over_ice - long_name = total sky surface downward longwave flux absorbed by the ground over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sfcnsw] - standard_name = surface_net_downwelling_shortwave_flux - long_name = total sky sfc netsw flx into ground - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[sfcdsw] - standard_name = surface_downwelling_shortwave_flux - long_name = total sky sfc downward sw flux - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[srflag] - standard_name = flag_for_precipitation_type - long_name = snow/rain flag for precipitation - units = flag - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[cm] - standard_name = surface_drag_coefficient_for_momentum_in_air_over_ice - long_name = surface exchange coeff for momentum over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[ch] - standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice - long_name = surface exchange coeff heat & moisture over ice - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsl1] - standard_name = air_pressure_at_lowest_model_layer - long_name = surface layer mean pressure - units = Pa - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslki] - standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer - long_name = Exner function ratio bt midlayer and interface at 1st layer - units = ratio - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prsik1] - standard_name = dimensionless_exner_function_at_lowest_model_interface - long_name = dimensionless Exner function at the ground surface - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[prslk1] - standard_name = dimensionless_exner_function_at_lowest_model_layer - long_name = dimensionless Exner function at the lowest model layer - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[wind] - standard_name = wind_speed_at_lowest_model_layer - long_name = wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[flag_iter] - standard_name = flag_for_iteration - long_name = flag for iteration - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F -[lprnt] - standard_name = flag_print - long_name = switch for printing sample column to stdout - units = flag - dimensions = () - type = logical - intent = in - optional = F -[ipr] - standard_name = horizontal_index_of_printed_column - long_name = horizontal index of printed column - units = index - dimensions = () - type = integer - intent = in - optional = F -[me] - standard_name = mpi_rank - long_name = current MPI-rank - units = index - dimensions = () - type = integer - intent = in - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea-ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[fice] - standard_name = sea_ice_concentration - long_name = sea-ice concentration [0,1] - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tice] - standard_name = sea_ice_temperature_interstitial - long_name = sea-ice surface temperature use as interstitial - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_ice - long_name = water equiv of acc snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tskin] - standard_name = surface_skin_temperature_over_ice_interstitial - long_name = surface skin temperature over ice (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tprcp] - standard_name = nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ice - long_name = total precipitation amount in each time step over ice - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[tiice] - standard_name = internal_ice_temperature - long_name = sea ice internal temperature - units = K - dimensions = (horizontal_loop_extent,ice_vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[ep] - standard_name = surface_upward_potential_latent_heat_flux_over_ice - long_name = surface upward potential latent heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snwdph] - standard_name = surface_snow_thickness_water_equivalent_over_ice - long_name = water equivalent snow depth over ice - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[qsurf] - standard_name = surface_specific_humidity_over_ice - long_name = surface air saturation specific humidity over ice - units = kg kg-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[snowmt] - standard_name = surface_snow_melt - long_name = snow melt during timestep - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[gflux] - standard_name = upward_heat_flux_in_soil_over_ice - long_name = soil heat flux over ice - units = W m-2 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[cmm] - standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ice - long_name = momentum exchange coefficient over ice - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[chh] - standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_ice - long_name = thermal exchange coefficient over ice - units = kg m-2 s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[evap] - standard_name = kinematic_surface_upward_latent_heat_flux_over_ice - long_name = kinematic surface upward latent heat flux over ice - units = kg kg-1 m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_over_ice - long_name = kinematic surface upward sensible heat flux over ice - units = K m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F -[islmsk_cice] - standard_name = sea_land_ice_mask_cice - long_name = sea/land/ice mask cice (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[xlon_d] - standard_name = longitude_in_degree - long_name = longitude in degree east - units = degree_east - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = in - optional = F -[xlat_d] - standard_name = latitude_in_degree - long_name = latitude in degree north - units = degree_north - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out - optional = F -[errflg] - standard_name = ccpp_error_flag - long_name = error flag for error handling in CCPP - units = flag - dimensions = () - type = integer - intent = out - optional = F diff --git a/physics/debug/sfcsub.F_dbg b/physics/debug/sfcsub.F_dbg deleted file mode 100644 index e15e5c463..000000000 --- a/physics/debug/sfcsub.F_dbg +++ /dev/null @@ -1,8772 +0,0 @@ -!>\file sfcsub.F -!! This file contains gribcode for each parameter. - - -!>\defgroup mod_sfcsub GFS sfcsub Module -!!\ingroup LSMs -!> @{ -!! This module contains grib code for each parameter-used in subroutines sfccycle() -!! and setrmsk(). - module sfccyc_module - use machine , only : kind_io8,kind_io4 - 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/) -! - real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 - integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata - integer :: veg_type_landice - integer :: soil_type_landice - integer :: num_threads -! -! - contains - - function message(prefix,index) - implicit none - character(len=*), intent(in) :: prefix - integer, intent(in) :: index - ! Safety measure: prevent writing out of bounds, use a longer string than 8 characters - character(len=16) :: message - write(message,fmt='(a,a,i0)') trim(prefix), '-', index - end function message - - end module sfccyc_module - -!>\ingroup mod_GFS_phys_time_vary -!! 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 & - &, slmskl,slmskw,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,nthrds,nlunit & - &, sz_nml,input_nml_file & - &, min_ice & - &, 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), & - & me, nthrds - logical, intent(in) :: use_ufo, nst_anl - real (kind=kind_io8), intent(in) :: min_ice(len) - - 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,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) -! -!> 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=' ' -! -! -! 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,sicjmx=1.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 - 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, zero=0.0 - real (kind=kind_io8), parameter :: crit_lnd=1.0e-6, & - & crit_wat=1.0e-6 -! -! coefficients of blending forecast and interpolated clim -! (or analyzed) fields over sea or land(l) (not for clouds) -! 1.0 = use of forecast -! 0.0 = replace with interpolated analysis -! -! these values are set for analysis mode. -! -! variables land sea -! --------------------------------------------------------- -! surface temperature forecast analysis -! surface temperature forecast forecast (over sea ice) -! albedo forecast/analysis analysis -! sea-ice analysis analysis -! snow forecast/analysis forecast (over sea ice) -! roughness forecast/analysis forecast -! plant resistance analysis analysis -! soil wetness (layer) weighted average analysis -! soil temperature forecast analysis -! 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 forecast/analysis-weighted analysis -! -! note: if analysis file is not given, then time interpolated climatology -! is used. if analyiss file is given, it will be used as far as the -! 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) slmskl(len), slmskw(len) - real (kind=kind_io8) 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) -! - real (kind=kind_io8), allocatable, dimension(:) :: & - & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & - & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & - & vmnfcsd, vmxfcsd, slpfcsd, absfcsd - real (kind=kind_io8), allocatable, dimension(:,:) :: & - & smcfcsd, stcfcsd, albfcsd -! -! 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(lsoil) -! rec. 5 snow -! rec. 6 soilt(lsoil) -! 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 (lsoil) -! 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, 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 -! Set number of threads num_threads in sfccyc_module for later use -! to the value received from the calling routine (nthrds) - num_threads = nthrds -! - lprnt = .false. - 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) + 66.35) - tem2 = abs(rlo(i) - 109.01) - if(tem1 < 0.10 .and. tem2 < 0.10) 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 - elseif (ialb ==2) 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 == 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 == 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 >= 99999.) ctsfl = 1. - if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) -! - ctsfs=0. !... tsfc over sea - if (ftsfs >= 99999.) ctsfs=1. - if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) -! - do k=1,lsoil - csmcl(k) = 0. !... soilm over land - if (fsmcl(k) >= 99999.) csmcl(k) = 1. - if (fsmcl(k) > 0. .and. fsmcl(k) < 99999) - & csmcl(k) = exp(-deltf/fsmcl(k)) - csmcs(k)=0. !... soilm over sea - if (fsmcs(k) >= 99999.) csmcs(k) = 1. - if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) - & csmcs(k) = exp(-deltf/fsmcs(k)) - enddo -! - calbl = 0. !... albedo over land - if (ialb == 2) falbl=99999. - if (falbl >= 99999.) calbl = 1. - if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) -! - calfl=0. !... fraction field for albedo over land - if (falfl >= 99999.) calfl = 1. - if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) -! - calbs=0. !... albedo over sea - if (falbs >= 99999.) calbs = 1. - if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) -! - calfs = 0. !... fraction field for albedo over sea - if (falfs >= 99999.) calfs = 1. - if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) -! - caisl = 0. !... sea ice over land - if (faisl >= 99999.) caisl = 1. - if (faisl > 0. .and. faisl < 99999) caisl = 1. -! - caiss = 0. !... sea ice over sea - if (faiss >= 99999.) caiss = 1. - if (faiss > 0. .and. faiss < 99999) caiss = 1. -! - csnol = 0. !... snow over land - if (fsnol >= 99999.) csnol = 1. - if (fsnol > 0. .and. fsnol < 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 < 0.) csnol = fsnol -! - csnos = 0. !... snow over sea - if (fsnos >= 99999.) csnos = 1. - if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) -! - czorl = 0. !... roughness length over land - if (fzorl >= 99999.) czorl = 1. - if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) -! - czors = 0. !... roughness length over sea - if (fzors >= 99999.) czors = 1. - if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) -! -! cplrl = 0. !... plant resistance over land -! if (fplrl >= 99999.) cplrl = 1. -! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) -! -! cplrs = 0. !... plant resistance over sea -! if (fplrs >= 99999.) cplrs = 1. -! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) -! - do k=1,lsoil - cstcl(k) = 0. !... soilt over land - if (fstcl(k) >= 99999.) cstcl(k) = 1. - if (fstcl(k) > 0. .and. fstcl(k) < 99999) & - & cstcl(k) = exp(-deltf/fstcl(k)) - cstcs(k) = 0. !... soilt over sea - if (fstcs(k) >= 99999.) cstcs(k) = 1. - if (fstcs(k) > 0. .and. fstcs(k) < 99999) & - & cstcs(k) = exp(-deltf/fstcs(k)) - enddo -! - cvegl = 0. !... vegetation fraction over land - if (fvegl >= 99999.) cvegl = 1. - if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) -! - cvegs = 0. !... vegetation fraction over sea - if (fvegs >= 99999.) cvegs = 1. - if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) -! - cvetl = 0. !... vegetation type over land - if (fvetl >= 99999.) cvetl = 1. - if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) -! - cvets = 0. !... vegetation type over sea - if (fvets >= 99999.) cvets = 1. - if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) -! - csotl = 0. !... soil type over land - if (fsotl >= 99999.) csotl = 1. - if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) -! - csots = 0. !... soil type over sea - if (fsots >= 99999.) csots = 1. - if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) - -!cwu [+16l]--------------------------------------------------------------- -! - csihl = 0. !... sea ice thickness over land - if (fsihl >= 99999.) csihl = 1. - if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) -! - csihs = 0. !... sea ice thickness over sea - if (fsihs >= 99999.) csihs = 1. - if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) -! - csicl = 0. !... sea ice concentration over land - if (fsicl >= 99999.) csicl = 1. - if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) -! - csics = 0. !... sea ice concentration over sea - if (fsics >= 99999.) csics = 1. - if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) - -!clu [+32l]--------------------------------------------------------------- -! - cvmnl = 0. !... min veg cover over land - if (fvmnl >= 99999.) cvmnl = 1. - if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) -! - cvmns = 0. !... min veg cover over sea - if (fvmns >= 99999.) cvmns = 1. - if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) -! - cvmxl = 0. !... max veg cover over land - if (fvmxl >= 99999.) cvmxl = 1. - if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) -! - cvmxs = 0. !... max veg cover over sea - if (fvmxs >= 99999.) cvmxs = 1. - if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) -! - cslpl = 0. !... slope type over land - if (fslpl >= 99999.) cslpl = 1. - if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) -! - cslps = 0. !... slope type over sea - if (fslps >= 99999.) cslps = 1. - if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) -! - cabsl = 0. !... snow albedo over land - if (fabsl >= 99999.) cabsl = 1. - if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) -! - cabss = 0. !... snow albedo over sea - if (fabss >= 99999.) cabss = 1. - if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) -!clu ---------------------------------------------------------------------- -! -!> - 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) -! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) -! - if (me == 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)) -! -! do i=1,len -! if (landfrac(i) > crit_lnd) then -! slmskl(i) = one -! slmskw(i) = one -! if (one-landfrac(i) > crit_wat) then -! slmskw(i) = zero -! if (sicfcs(i) > min_ice(i)) then -! slmskw(i) = 2.0_kind_io8 -! endif -! endif -! else -! slmskl(i) = zero -! slmskw(i) = zero -! if (sicfcs(i) > min_ice(i)) then -! slmskl(i) = 2.0_kind_io8 -! slmskw(i) = 2.0_kind_io8 -! endif -! endif -! if (i == 1) write(0,*)' landfrac=',landfrac(i),' slmskl=', & -! if (i == 1) write(0,*)' slmskl=', slmskl(i),' slmskw=', & -! & slmskw(i),' sicfcs=',sicfcs(i) -! enddo - -! write(1000+me,*)' slmskl=',slmskl -! write(1000+me,*)' slmskw=',slmskw -! -! read glacier -! - kpd9 = -1 - kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl - &, 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,slmskl - &, 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,slmskl,slmskw, - & 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,slmskl,albomx,len) -! -! make sure vegetation type and soil type are non zero over land -! - call landtyp(vetclm,sotclm,slpclm,slmskl,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) /= ' ') then -!cwu [+5l/-1l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*aisclm(i) - sicclm(i) = aisclm(i) - if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i) /= 1.0) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo - crit=aislim -!* crit=0.5 -! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', min_ice) - - elseif(fnacnc(1:8) /= ' ') then -!cwu [+4l] update sihclm, sicclm - do i=1,len - sihclm(i) = 3.0*acnclm(i) - sicclm(i) = acnclm(i) - if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicclm(i).ne.1.) then - sicclm(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', min_ice) - do i=1,len - aisclm(i) = acnclm(i) - enddo - endif -! -! quality control of sea ice mask -! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmskw,aisclm,len,aicice,sliclm) - - if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' - *,sliclm(iprnt),' slmskw=',slmskw(iprnt) -! -! write(6,*) 'sliclm' -! znnt=1. -! call nntprt(sliclm,len,znnt) -! -! quality control of snow -! - call qcsnow(snoclm,slmskl,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) > 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) -! - !-- soil moisture - if(fnsmcc(1:8).eq.' ') then - call getsmc(wetclm,len,lsoil,smcclm,me) - endif - do k=1,lsoil - call qcmxmn(message('stc',k),smcclm(1,k),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - !-- soil temperature - if(fnstcc(1:8).eq.' ') then - call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) - endif - do k=1,lsoil - call qcmxmn(message('stc',k),stcclm(1,k),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - 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 == 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) - do k=1,lsoil - call monitr(message('smcclm',k),smcclm(1,k),sliclm,snoclm,len) - call monitr(message('stcclm',k),stcclm(1,k),sliclm,snoclm,len) - enddo - call monitr('tg3clm',tg3clm,sliclm,snoclm,len) - call monitr('zorclm',zorclm,sliclm,snoclm,len) -! if (gaus) then - 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 == 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,slmskl,slmskw, - & 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,slmskw,ztsfc,len,rlapse) - endif -! -! ice concentration or ice mask (only ice mask used in the model now) -! - if(fnaisa(1:8) /= ' ') then -!cwu [+5l/-1l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*aisanl(i) - sicanl(i) = aisanl(i) - if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! crit=aislim -!* crit=0.5 -! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', min_ice) - elseif(fnacna(1:8) /= ' ') then -!cwu [+17l] update sihanl, sicanl - do i=1,len - sihanl(i) = 3.0*acnanl(i) - sicanl(i) = acnanl(i) - if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & - & .and. sicanl(i) /= 1.) then - sicanl(i) = sicimx - sihfcs(i) = glacir_hice - endif - enddo -! crit=aislim - do i=1,len - crit = min_ice(i) - if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then - slianl(i) = 2.0_kind_io8 -! print *,'cycle - new ice form: fice=',sicanl(i) - elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then - slianl(i) = 0. -! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then - if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid - slianl(i) = 2.0_kind_io8 - else -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i) = 0.0_kind_io8 - endif - 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) - call rof01_len(acnanl, len, 'ge', min_ice) - do i=1,len - aisanl(i) = acnanl(i) - enddo - endif - if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' - &,glacir(iprnt),' slmskw=',slmskw(iprnt) -! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, - & rla,rlo,len,me) -! -! set ocean/land/sea-ice mask -! - call setlsi(slmskw,aisanl,len,aicice,slianl) - if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' - *,slianl(iprnt),' slmskw=',slmskw(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,slmskl,albomx,len) -! -! quality control of snow and sea-ice -! process snow depth or snow cover -! - if (fnsnoa(1:8) /= ' ') then - call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmskl,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,slmskl,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,slmskl,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) > 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) /= ' ' .or. fnweta(1:8) /= ' ' ) 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) == ' ' .and. fnsmcc(1:8) == ' ') then - call getsmc(wetanl,len,lsoil,smcanl,me) - endif - !-- soil moisture - do k=1,lsoil - call qcmxmn(message('smca',k),smcanl(1,1),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - !-- soil temperature - if(fnstca(1:8).eq.' ') then - call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) - endif - do k=1,lsoil - call qcmxmn(message('stca',k),stcanl(1,1),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - 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 == 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) - do k=1,lsoil - call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) - enddo - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) -! if (gaus) then - 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 == 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 == 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) /= 0.) then - call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, - & tsfimx) - do i=1,len - icefl2(i) = sicfcs(i) > 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,slmskl,ztsfc,len,-rlapse) - endif - ztsfc = 0. - call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse) - else - ztsfc = 0. - call tsfcor(tsffcs,orog,slmskw,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) /= 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo - enddo -!clu ----------------------------------------------------------------------- -! - if (lqcbgs .and. irtacn == 0) then - call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmskl,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) /= ' ' .or. fnweta(1:8) /= ' ' ) - & 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) -!-- soil moisture forecast - do k=1,lsoil - call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs, - & snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo -!-- soil temperature forecast - do k=1,lsoil - call qcmxmn(message('stcf',k),stcfcs(1,k),slifcs, - & snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - 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 == 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) - do k=1,lsoil - call monitr(message('smcfcs',k),smcfcs(1,k),slifcs,snofcs,len) - call monitr(message('stcfcs',k),stcfcs(1,k),slifcs,snofcs,len) - enddo - call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) - call monitr('zorfcs',zorfcs,slifcs,snofcs,len) -! if (gaus) then - 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) - - do i=1,len - if (sicanl(i) >= min_ice(i)) then - slianl(i) = 2.0_kind_io8 - else - slianl(i) = zero - sicanl(i) = zero - endif - enddo - - 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 == 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 -! - if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:) - if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:) - call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & slmskl,slmskw,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) - if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:) - if(lprnt) print *,' stcanlmer=',stcanl(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) - if(lprnt) print *,' stcan=',stcanl(iprnt,:) -! -! set tsfc to tsnow over snow -! - call snosfc(snoanl,tsfanl,tsfsmx,len,me) -! - do i=1,len - icefl2(i) = sicanl(i) > 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) /= ' ' .or. fnweta(1:8) /= ' ') 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 - do k=1,lsoil - call qcmxmn(message('stcm',k),stcanl(1,k),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - do k=1,lsoil - call qcmxmn(message('smcm',k),smcanl(1,k),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - enddo - 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 == 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,slmskl,ztsfc,len,rlapse) - endif - ztsfc = 0. - call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse) - else - ztsfc = 0. - call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse) - endif - if(lprnt) print *,' tsfaf=',tsfanl(iprnt) -! -! check the final merged product -! - if (monmer) then - if(me == 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) - do k=1,lsoil - call monitr(message('smcanl',k),smcanl(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcanl(1,k),slianl,snoanl,len) - enddo - if (lsoil > 2) then - call monitr('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 - allocate (tsffcsd(len), snofcsd(len), tg3fcsd(len), & - & zorfcsd(len), slifcsd(len), aisfcsd(len), & - & cnpfcsd(len), vegfcsd(len), vetfcsd(len), & - & sotfcsd(len), sihfcsd(len), sicfcsd(len), & - & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & - & absfcsd(len)) - allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & - & albfcsd(len,4)) - do i=1,len - tsffcsd(i) = tsfanl(i) - tsffcs(i) - snofcsd(i) = snoanl(i) - snofcs(i) - tg3fcsd(i) = tg3anl(i) - tg3fcs(i) - zorfcsd(i) = zoranl(i) - zorfcs(i) -! plrfcs(i) = plranl(i) - plrfcs(i) -! albfcs(i) = albanl(i) - albfcs(i) - slifcsd(i) = slianl(i) - slifcs(i) - aisfcsd(i) = aisanl(i) - aisfcs(i) - cnpfcsd(i) = cnpanl(i) - cnpfcs(i) - vegfcsd(i) = veganl(i) - vegfcs(i) - vetfcsd(i) = vetanl(i) - vetfcs(i) - sotfcsd(i) = sotanl(i) - sotfcs(i) -!clu [+2l] add sih, sic - sihfcsd(i) = sihanl(i) - sihfcs(i) - sicfcsd(i) = sicanl(i) - sicfcs(i) -!clu [+4l] add vmn, vmx, slp, abs - vmnfcsd(i) = vmnanl(i) - vmnfcs(i) - vmxfcsd(i) = vmxanl(i) - vmxfcs(i) - slpfcsd(i) = slpanl(i) - slpfcs(i) - absfcsd(i) = absanl(i) - absfcs(i) - enddo - do j = 1,lsoil - do i = 1,len - smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j) - stcfcsd(i,j) = stcanl(i,j) - stcfcs(i,j) - enddo - enddo - do j = 1,4 - do i = 1,len - albfcsd(i,j) = albanl(i,j) - albfcs(i,j) - enddo - enddo -! -! monitoring prints -! - if(me == 0) then - print *,' ' - print *,'monitor of difference' - print *,' (includes angulation correction)' - print *,' ' - call monitr('tsfdif', tsffcsd,slianl,snoanl,len) - call monitr('albdif', albfcsd,slianl,snoanl,len) - call monitr('albdif1',albfcsd,slianl,snoanl,len) - call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len) - call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len) - call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len) - call monitr('aisdif', aisfcsd,slianl,snoanl,len) - call monitr('snodif', snofcsd,slianl,snoanl,len) - do k=1,lsoil - call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len) - enddo - call monitr('tg3dif',tg3fcsd,slianl,snoanl,len) - call monitr('zordif',zorfcsd,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',slifcsd,slianl,snoanl,len) -! call monitr('plrdif',plrfcs,slianl,snoanl,len) - call monitr('cnpdif',cnpfcsd,slianl,snoanl,len) - call monitr('vegdif',vegfcsd,slianl,snoanl,len) - call monitr('vetdif',vetfcsd,slianl,snoanl,len) - call monitr('sotdif',sotfcsd,slianl,snoanl,len) -!cwu [+2l] add sih, sic - call monitr('sihdif',sihfcsd,slianl,snoanl,len) - call monitr('sicdif',sicfcsd,slianl,snoanl,len) -!clu [+4l] add vmn, vmx, slp, abs - call monitr('vmndif',vmnfcsd,slianl,snoanl,len) - call monitr('vmxdif',vmxfcsd,slianl,snoanl,len) - call monitr('slpdif',slpfcsd,slianl,snoanl,len) - call monitr('absdif',absfcsd,slianl,snoanl,len) - endif - deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & - & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & - & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & - & absfcsd) - deallocate (smcfcsd, stcfcsd, albfcsd) - 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) > 0.0_kind_io8) then - stcfcs(i,j) = stcanl(i,j) - else - stcfcs(i,j) = tsffcs(i) - endif - enddo - enddo - if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', & - & slifcs(iprnt) - 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 - if (slmskw(i) == zero) then - crit = min_ice(i) - if (sicanl(i) >= crit) then - sihfcs(i) = sihanl(i) - sitfcs(i) = tsffcs(i) - if (sicfcs(i) >= crit) then - tem1 = 1.0_kind_io8 / sicfcs(i) - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem1 - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 - sicfcs(i) = sicanl(i) - else - tsffcs(i) = tgice - sitfcs(i) = tgice - sicfcs(i) = sicanl(i) - sihfcs(i) = sihnew - endif - if (lprnt .and. i == iprnt) write(0,*)' sicanl=',sicanl(i), & - &' sicfcs=',sicfcs(i),' siccanl=',sicanl(i),' sihfcs=',sihfcs(i) - else - tsffcs(i) = tsfanl(i) - sihfcs(i) = 0.0_kind_io8 - sicfcs(i) = 0.0_kind_io8 - slifcs(i) = 0.0_kind_io8 - sitfcs(i) = tsffcs(i) - endif - endif - if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then - print *,'warning: check, slifcs and sicfcs', & - & slifcs(i),sicfcs(i) - endif - enddo - -! do i=1,len -! if (slifcs(i) < 1.5_kind_io8) then -! sihfcs(i) = 0.0_kind_io8 -! sicfcs(i) = 0.0_kind_io8 -! sitfcs(i) = tsffcs(i) -! else -! crit = min_ice(i) -! if (sicfcs(i) < crit) then -! print *,'warning: check, slifcs and sicfcs', & -! & slifcs(i),sicfcs(i) -! endif -! endif -! enddo - -! -! ensure the consistency between slc and smc -! - do k=1, lsoil - fixratio(k) = .false. - if (fsmcl(k) < 99999.) fixratio(k) = .true. - enddo - - if(me == 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) == -999.) then - slcfcs(i,k) = smcfcs(i,k) - else - slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) - endif - if (slifcs(i) /= 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) == 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 < 99999.) then - if(me == 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i) == 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) /= 1) swdfcs(i) = 3.*snofcs(i) - enddo - - do i = 1, len - if(slifcs(i) == 1.) then - if(snofcs(i) /= 0. .and. swdfcs(i) == 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) == 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) - if(lprnt) print *,' stcfcsend=',stcfcs(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 -!! 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 - 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 - use sfccyc_module , only : num_threads - 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(:) -! - 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 - data first /.true./ - save first -! - integer len_thread_m, len_thread, i1_t, i2_t -! - if (first) then - 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 & - &, ' slmask=',slmask(i),' me=',me & - &, ' outlon=',outlon(i),' outlat=',outlat(i) - &, '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, & - & 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) & - &, 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 - 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,slmskl,slmskw, & - & 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, & !cggg snow mods - & 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, & - & 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 -! - real (kind=kind_io8) slmskl(len), slmskw(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 - &, 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) & - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) -! - logical gaus -! -! tsf -! - irttsf = 1 - if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmskw, - & 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,slmskw, - & 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),slmskl, - & iy,im,id,ih,fh,albanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalb = iret - if(iret == 1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret == -1) then - if (me == 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 == 0 .and. kk == 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me == 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),slmskl, - & iy,im,id,ih,fh,alfanl(1,kk),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - irtalf = iret - if(iret == 1) then - write(6,*) 'albedo analysis read error' - call abort - elseif(iret == -1) then - if (me == 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 == 0 .and. kk == 4) - & print *,'albedo analysis provided.' - endif - enddo - else - if (me == 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,slmskl, - & 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,slmskl, - & iy,im,id,ih,fh,smcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnsmca,kpdsmc,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskw, - & 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,slmskw, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & iy,im,id,ih,fh,stcanl(1,1),len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - call fixrda(lugb,fnstca,kpdstc,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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, & - & 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) & - &, 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', & - & ' 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 == 'ge') then - do i=1,len - if(aisfld(i) >= crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'gt') then - do i=1,len - if(aisfld(i) > crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'le') then - do i=1,len - if(aisfld(i) <= crit) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'lt') then - do i=1,len - if(aisfld(i) < 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 rof01_len(aisfld, len, op, crit) - use machine , only : kind_io8,kind_io4 - implicit none - integer i,len - real (kind=kind_io8), intent(in) :: crit(len) - real (kind=kind_io8) aisfld(len) - character*2 op -! - if(op == 'ge') then - do i=1,len - if(aisfld(i) >= crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'gt') then - do i=1,len - if(aisfld(i) > crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'le') then - do i=1,len - if(aisfld(i) <= crit(i)) then - aisfld(i) = 1. - else - aisfld(i) = 0. - endif - enddo - elseif(op == 'lt') then - do i=1,len - if(aisfld(i) < crit(i)) 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 - -!>\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 - 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 -!! This subroutine merges analysis and forecast. - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & - & slmskl,slmskw,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, & - & num_threads, zero, one - 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) slmskl(len), slmskw(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) & - &, 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 - data first /.true./ - save first -! - integer len_thread_m, i1_t, i2_t, it -! - if (first) then - 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,rsics - 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs,rsics=',11f7.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) == zero) 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) == zero) then -! if(slmskw(i) == zero) 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 - endif - if(slmskl(i) == one .or. slianl(i) > zero) then - 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, & - & 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, & - & 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 (nint(slifcs(i)) /= nint(slianl(i))) then - if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 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 (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 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 (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 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 == 0) then - if (kount1 > 0) then - write(6,*) 'sea ice melted. tsf,alb,zor are filled', - & ' at ',kount1,' points' - endif - if(kount2 > 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 == 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) == aicice .and. slmask(i) == 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 - use sfccyc_module , only : num_threads - implicit none - integer, intent(in) :: len, mode, me - real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, & - & fldlmx,fldlmn,fldomx,fldjmn, & - & fldsmx,fldsmn,epsfld,percrit & - integer, parameter :: mmprt=2 -! - character(len=*) ttl - logical iceflg(len) - real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo - logical lgchek -! - logical first - real (kind=kind_io8) permax, per - data first /.true./ - save first -! - integer :: len_thread_m, i1_t, i2_t, it, & - & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & - & ij,nprt,kmaxs,kmins,i - integer :: islimsk(len), iwk(len) -! - if (first) then - first = .false. - endif - do it=1,len - islimsk(it) = nint(slimsk(it)) - enddo -! -! check against land-sea mask and ice cover mask -! - if(me == 0) then - 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,islimsk,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 /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kminl - fld(iwk(i)) = fldlmn - enddo - endif - endif -! -! upper bound check over bare land -! - if (fldlmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) <= 0.0 & - & .and. fld(i) > 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 == 1) then - do i=1,kmaxl - fld(iwk(i)) = fldlmx - enddo - endif - endif -! -! lower bound check over snow covered land -! - if (fldsmn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kmins - fld(iwk(i)) = fldsmn - enddo - endif - endif -! -! upper bound check over snow covered land -! - if (fldsmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 1 .and. sno(i) > 0.0 & - & .and. fld(i) > 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 == 1) then - do i=1,kmaxs - fld(iwk(i)) = fldsmx - enddo - endif - endif -! -! lower bound check over open ocean -! - if (fldomn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 0.0 .and. fld(i) < 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 == 1) then - do i=1,kmino - fld(iwk(i)) = fldomn - enddo - endif - endif -! -! upper bound check over open ocean -! - if (fldomx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) ==.0 .and. fld(i) > 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 == 1) then - do i=1,kmaxo - fld(iwk(i)) = fldomx - enddo - endif - endif -! -! lower bound check over sea ice without snow -! - if (fldimn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 & - & .and. fld(i) < 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 == 1) then - do i=1,kmini - fld(iwk(i)) = fldimn - enddo - endif - endif -! -! upper bound check over sea ice without snow -! - if (fldimx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & - & fld(i) > 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 == 1) then - do i=1,kmaxi - fld(iwk(i)) = fldimx - enddo - endif - endif -! -! lower bound check over sea ice with snow -! - if (fldjmn /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & - & fld(i) < 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 == 1) then - do i=1,kminj - fld(iwk(i)) = fldjmn - enddo - endif - endif -! -! upper bound check over sea ice with snow -! - if (fldjmx /= 999.0) then - do i=i1_t,i2_t - if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & - & fld(i)> 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 == 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 == 0) then - permax = 0.0 - if(kminl > 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 > permax) permax = per - endif - if(kmaxl > 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 > 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 > 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 >.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 > 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 > 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 > 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 > permax) permax=per - endif - if(kminj > 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 > 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 > 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), smcclm(len,lsoil) -! - if (me == 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. -! TG3 MODS BEGIN - if(kpds5 == kpdtsf .and. imax == 138 .and. jmax == 116 - & .and. kpds4 == 128) then -! print*,'turn off setrmsk for tg3' - lmask = .false. - - elseif(kpds5 == kpdtsf) then -! TG3 MODS END -! -! surface temperature -! - 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 == 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 -!! 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 - use sfccyc_module , only : num_threads - 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 - data first /.true./ - save first -! - integer len_thread_m, j1_t, j2_t, it -! - if (first) then - 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 - - end subroutine landtyp - -!>\ingroup mod_sfcsub - 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,slmskl,slmskw, & - & 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) slmskl(len), slmskw(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 > 0.0) then -!cbosu - if (me == 0) print*,'bosu fh gt 0' - - iy4 = iy - if (iy < 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 == 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 < dayhf(1)) rjday = rjday + 365. -! - if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 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 == 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, - & 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 < 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 < dayhf(1)) rjday = rjday + 365. - - if (me == 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', - & jy,jm,jd,jh,rjday -! - if (me == 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 >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1m -! wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) - if (mon2 == 13) mon2 = 1 - if (me == 0) print *,'rjday,mon1,mon2,wei1m,wei2m=', - & rjday,mon1,mon2,wei1m,wei2m -! -! for seasonal mean climatology -! - monend = 4 - is = im/3 + 1 - if (is == 5) is = 1 - do mm=1,monend - mmm = mm*3 - 2 - mmp = (mm+1)*3 - 2 - if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1s -! wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) - if (sea2 == 13) sea2 = 1 - if (me == 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 == 3) is = 1 - do mm=1,monend - mmm = mm*6 - 5 - mmp = (mm+1)*6 - 5 - if(rjday >= dayhf(mmm) .and. rjday < 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 = 1.0 - wei1y -! wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) - if (hyr2 == 13) hyr2 = 1 - if (me == 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 .or. ialb == 2) then -!cbosu still need facsf and facwf. read them from the production file - if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl - &, 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,slmskl - &, alf,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) - endif - do i = 1, len - if(slmskl(i) == 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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 == 5) is1 = 1 - if (is2 == 5) is2 = 1 - do nn=1,2 -! -! seasonal mean climatology - if(nn == 1) then - isx = is1 - else - isx = is2 - endif - if(isx == 1) kpd9 = 12 - if(isx == 2) kpd9 = 3 - if(isx == 3) kpd9 = 6 - if(isx == 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,slmskl, - & 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 .or. ialb == 2) then - if ( index(fnalbc, "tileX.nc") == 0) then ! grib file - kpd7=-1 - do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, - & 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,slmskw, - & 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,slmskw, -! & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskw, - & 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,slmskw, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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 == 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,slmskw, - & 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 == 5) isx = 1 - if (isx == 1) kpd9 = 12 - if (isx == 2) kpd9 = 3 - if (isx == 3) kpd9 = 6 - if (isx == 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,slmskl - &, 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 .or. ialb == 2) 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,slmskl, - & 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,slmskw, - & 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,slmskl, - & 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,slmskl, - & 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,slmskw, - & 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,slmskw, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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,slmskl, - & 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 .or. ialb == 2) 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 -!! 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 & - &, jj,w3kindreal,w3kindint - real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto -! -! - 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/flake_driver.meta b/physics/flake_driver.meta index b160dd7de..959b5b43f 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -114,8 +114,8 @@ intent = in optional = F [weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice units = mm dimensions = (horizontal_loop_extent) type = real @@ -217,8 +217,8 @@ intent = in optional = F [snwdph] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice units = mm dimensions = (horizontal_loop_extent) type = real diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index a27b02e0d..271ca5a24 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -69,7 +69,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & qsfc_wat, qsfc_lnd, qsfc_ice, & !intent(in) - & snowh_wat, snowh_lnd, snowh_ice, & !intent(in) + & snowh_lnd, snowh_ice, & !intent(in) & znt_wat, znt_lnd, znt_ice, & !intent(inout) & ust_wat, ust_lnd, ust_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) @@ -163,7 +163,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snowh_wat, snowh_lnd, snowh_ice + & snowh_lnd, snowh_ice real(kind=kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & @@ -194,7 +194,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real, dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & - & cpm, qgh, qfx, qsfc_ruc + & cpm, qgh, qfx, qsfc_ruc, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & & pattern_spp_pbl, dz, th, qv @@ -233,13 +233,14 @@ SUBROUTINE mynnsfc_wrapper_run( & else xland(i)=2.0 endif - qgh(i)=0.0 - mavail(i)=1.0 - !snowh(i)=snowd(i)*800. !mm -> m - !znt_lnd(i)=znt_lnd(i)*0.01 !cm -> m - !znt_wat(i)=znt_wat(i)*0.01 !cm -> m - !znt_ice(i)=znt_ice(i)*0.01 !cm -> m - cpm(i)=cp + qgh(i) = 0.0 + mavail(i) = 1.0 + !snowh(i) = snowd(i)*800. !mm -> m + !znt_lnd(i) = znt_lnd(i)*0.01 !cm -> m + !znt_wat(i) = znt_wat(i)*0.01 !cm -> m + !znt_ice(i) = znt_ice(i)*0.01 !cm -> m + cpm(i) = cp + snowh_wat(i) = 0.0 enddo ! cm -> m diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index d082752c4..94393057b 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -391,15 +391,6 @@ kind = kind_phys intent = inout optional = F -[snowh_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowh_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index bff171f4b..445eb0dc4 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -72,7 +72,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) - & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) + & snwdph_lnd,snwdph_ice, & !intent(in) & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) @@ -109,7 +109,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snwdph_wat,snwdph_lnd,snwdph_ice + & snwdph_lnd,snwdph_ice real(kind=kind_phys), dimension(:), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(:), intent(inout) :: & @@ -138,7 +138,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys) :: tv1 - real(kind=kind_phys) :: tvs, z0, z0max + real(kind=kind_phys) :: tvs, z0, z0max, snwdph_wat ! real(kind=kind_phys), parameter :: & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp @@ -174,6 +174,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + snwdph_wat = zero + do i=1,im if(flag_iter(i)) then @@ -358,7 +360,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), snwdph_wat(i), thv1, wind(i), + & (z1(i), snwdph_wat, thv1, wind(i), & z0max, ztmax_wat(i), tvs, grav, tv1, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 7b639b6b0..e7551cf99 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -312,15 +312,6 @@ kind = kind_phys intent = in optional = F -[snwdph_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snwdph_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land From 05a702e91f234ac8d6f396d93c1bc9a53848d71b Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 16:07:35 +0000 Subject: [PATCH 127/165] removing original flake_driver --- physics/flake_driver.F90_orig | 411 ---------------------------------- 1 file changed, 411 deletions(-) delete mode 100644 physics/flake_driver.F90_orig diff --git a/physics/flake_driver.F90_orig b/physics/flake_driver.F90_orig deleted file mode 100644 index 1e8714461..000000000 --- a/physics/flake_driver.F90_orig +++ /dev/null @@ -1,411 +0,0 @@ -!> \file flake_driver.F90 -!! This file contains the flake scheme driver. - -!> This module contains the CCPP-compliant flake scheme driver. - module flake_driver - - implicit none - - private - - public :: flake_driver_init, flake_driver_run, flake_driver_finalize - - contains - -!> \section arg_table_flake_driver_init Argument Table -!! \htmlinclude flake_driver_init.html -!! - subroutine flake_driver_init (errmsg, errflg) - - implicit none - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine flake_driver_init - -!> \section arg_table_flake_driver_finalize Argument Table -!! \htmlinclude flake_driver_finalize.html -!! - subroutine flake_driver_finalize (errmsg, errflg) - - implicit none - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - end subroutine flake_driver_finalize - -!> \section arg_table_flake_driver_run Argument Table -!! \htmlinclude flake_driver_run.html -!! - SUBROUTINE flake_driver_run ( & -! ---- Inputs - im, ps, t1, q1, wind, & - dlwflx, dswsfc, weasd, lakedepth, & - use_flake, xlat, delt, zlvl, elev, & - wet, flag_iter, yearlen, julian, imon, & -! ---- in/outs - snwdph, hice, tsurf, fice, T_sfc, hflx, evap, & - ustar, qsfc, ch, cm, chh, cmm, & - errmsg, errflg ) - -!============================================================================== -! -! Declarations -! use module_flake_ini, only:flake_init - use module_FLake -! use flake_albedo_ref -! use data_parameters -! use flake_derivedtypes -! use flake_paramoptic_ref -! use flake_parameters - use machine , only : kind_phys -! use funcphys, only : fpvs -! use physcons, only : grav => con_g, cp => con_cp, & -! & hvap => con_hvap, rd => con_rd, & -! & eps => con_eps, epsm1 => con_epsm1, & -! & rvrdm1 => con_fvirt - -!============================================================================== -IMPLICIT NONE - - integer, intent(in) :: im, imon,yearlen -! integer, dimension(im), intent(in) :: islmsk - - real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & - & t1, q1, dlwflx, dswsfc, zlvl, elev - - real (kind=kind_phys), intent(in) :: delt - - real (kind=kind_phys), dimension(:), intent(in) :: & - & xlat, weasd, lakedepth - - real (kind=kind_phys),dimension(:),intent(inout) :: & - & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm - - real (kind=kind_phys), intent(in) :: julian - - logical, dimension(:), intent(in) :: flag_iter, wet, use_flake - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals - - real (kind=kind_phys) , parameter :: lake_pct_min = 0.1 - - real (kind=kind_phys), dimension(im) :: & - T_snow , & ! Temperature at the air-snow interface [K] - T_ice , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw , & ! Mean temperature of the water column [K] - T_wML , & ! Mixed-layer temperature [K] - T_bot , & ! Temperature at the water-bottom sediment interface [K] - T_B1 , & ! Temperature at the upper layer of the sediments [K] - C_T , & ! Shape factor (thermocline) - fetch , & ! Typical wind fetch [m] - h_ML , & ! Thickness of the mixed-layer [m] - H_B1 , & ! Thickness of the upper layer of bottom sediments [m] - w_albedo , & ! - w_extinc - -! Input (procedure arguments) - -REAL (KIND = kind_phys) :: & - - dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] - I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] - Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] - height_u_in , & ! Height above the lake surface where the wind speed is measured [m] - height_tq_in , & ! Height where temperature and humidity are measured [m] - U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] - T_a_in , & ! Air temperature at z=height_tq_in [K] - q_a_in , & ! Air specific humidity at z=height_tq_in - P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] - -REAL (KIND = kind_phys) :: & - depth_w , & ! The lake depth [m] - fetch_in , & ! Typical wind fetch [m] - depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] - T_bs_in , & ! Temperature at the outer edge of - ! the thermally active layer of the bottom sediments [K] - par_Coriolis , & ! The Coriolis parameter [s^{-1}] - del_time ! The model time step [s] - -REAL (KIND = kind_phys) :: & - T_snow_in , & ! Temperature at the air-snow interface [K] - T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_in , & ! Mean temperature of the water column [K] - T_wML_in , & ! Mixed-layer temperature [K] - T_bot_in , & ! Temperature at the water-bottom sediment interface [K] - T_B1_in , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_in , & ! Shape factor (thermocline) - h_snow_in , & ! Snow thickness [m] - h_ice_in , & ! Ice thickness [m] - h_ML_in , & ! Thickness of the mixed-layer [m] - H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_in , & ! Surface temperature at the previous time step [K] - ch_in , & - cm_in , & - albedo_water , & - water_extinc - -REAL (KIND = kind_phys) :: & - T_snow_out , & ! Temperature at the air-snow interface [K] - T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] - T_mnw_out , & ! Mean temperature of the water column [K] - T_wML_out , & ! Mixed-layer temperature [K] - T_bot_out , & ! Temperature at the water-bottom sediment interface [K] - T_B1_out , & ! Temperature at the bottom of the upper layer of the sediments [K] - C_T_out , & ! Shape factor (thermocline) - h_snow_out , & ! Snow thickness [m] - h_ice_out , & ! Ice thickness [m] - h_ML_out , & ! Thickness of the mixed-layer [m] - H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_out , & ! surface temperature [K] - T_sfc_n , & ! Updated surface temperature [K] - u_star , & - q_sfc , & - chh_out , & - cmm_out - -REAL (KIND = kind_phys) :: & - Q_momentum , & ! Momentum flux [N m^{-2}] - Q_SHT_flx , & ! Sensible heat flux [W m^{-2}] - Q_LHT_flx , & ! Latent heat flux [W m^{-2}] - Q_watvap ! Flux of water vapour [kg m^{-2} s^{-1}] - -REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,Kbar, DelK - - -REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc - !initilizations - -INTEGER :: i,ipr,iter - -LOGICAL :: lflk_botsed_use -logical :: flag(im) -CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" - -!============================================================================== -! Start calculations -!------------------------------------------------------------------------------ -! FLake_write need to assign original value to make the model somooth - - lake_depth_max = 60.0 - ipr = min(im,10) - -! --- ... set flag for lake points - - do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) - enddo - - Kbar=3.5 - DelK=3.0 - - do i = 1, im - if (flag(i)) then - if( use_flake(i) ) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = 57.29578*abs(xlat(i)) - tt = 29.275+0.0813*dxlat-0.0052*dxlat*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-0.7566*dxlat+0.0051*dxlat*dxlat-0.0038*elev(i)+273.15 -! if(fice(i).le.0.0) then -! h_ice(i) = 0.0 -! h_snow(i)= 0.0 -! endif - if(snwdph(i).gt.0.0 .or. hice(i).gt.0.0) then - if(tsurf(i).lt.T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if(tsurf(i).lt.tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* tsurf(i) - endif -! -! Add empirical climatology of lake Tsfc and Tbot to the current Tsfc and Tbot -! to make sure Tsfc and Tbot are warmer than Tair in Winter or colder than Tair -! in Summer - - x = 0.03279*julian - if(xlat(i) .ge. 0.0) then - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) - 0.3*y - tb = tb - 0.05*y - endif - T_bot(i) = tb - T_B1(i) = tb - -! if(lakedepth(i).lt.10.0) then -! T_bot(i) = T_sfc(i) -! T_B1(i) = T_bot(i) -! endif - - T_mnw(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - T_wML(i) = C_T(i)*T_sfc(i)+(1-C_T(i))*T_bot(i) - h_ML(i) = C_T(i)* min ( lakedepth(i), lake_depth_max ) - H_B1(i) = min ( lakedepth(i),4.0) - hflx(i) = 0.0 - evap(i) = 0.0 - -! compute albedo as a function of julian day and latitute - temp = 2*3.14159265*(julian-1)/float(yearlen) - temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp)- & - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) - & - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) - w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) -! w_albedo(I) = 0.06 -! compute water extinction coefficient as a function of julian day - if(julian.lt.90 .or. julian .gt. 333) then - w_extinc(i) = Kbar-Kbar/DelK - else - w_extinc(i) = Kbar+Kbar/DelK*sin(2*3.14159265*(julian-151)/244) - endif -! w_extinc(i) = 3.0 - -! write(65,1002) julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print 1002 julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) -! print*,'inside flake driver' -! print*, julian,xlat(i),w_albedo(I),w_extinc(i),lakedepth(i),elev(i),tb,tt,tsurf(i),T_sfc(i) - - endif !lake - endif !flag - enddo - 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & - 1p, e12.3) -! 1002 format ( ' julian= ',F6.2,1x,5(F8.4,1x),3(f11.4,1x)) - 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) - - -! -! call lake interface - do i=1,im - if (flag(i)) then - if( use_flake(i) ) then - dMsnowdt_in = weasd(i)/delt - I_atm_in = dswsfc(i) - Q_atm_lw_in = dlwflx(i) - height_u_in = zlvl(i) - height_tq_in = zlvl(i) - U_a_in = wind(i) - T_a_in = t1(i) - q_a_in = q1(i) - P_a_in = ps(i) - ch_in = ch(i) - cm_in = cm(i) - albedo_water= w_albedo(i) - water_extinc= w_extinc(i) - - depth_w = min ( lakedepth(i), lake_depth_max ) - depth_bs_in = max ( 4.0, min ( depth_w * 0.2, 10.0 ) ) - fetch_in = fetch(i) - T_bs_in = T_bot(i) - par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) - del_time = delt - - do iter=1,10 !interation loop - T_snow_in = T_snow(i) - T_ice_in = T_ice(i) - T_mnw_in = T_mnw(i) - T_wML_in = T_wML(i) - T_bot_in = T_bot(i) - T_B1_in = T_B1(i) - C_T_in = C_T(i) - h_snow_in = snwdph(i) - h_ice_in = hice(i) - h_ML_in = h_ML(i) - H_B1_in = H_B1(i) - T_sfc_in = T_sfc(i) - - T_bot_2_in = T_bot(i) - Q_SHT_flx = hflx(i) - Q_watvap = evap(i) - -!------------------------------------------------------------------------------ -! Set the rate of snow accumulation -!------------------------------------------------------------------------------ - - CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & - height_tq_in, U_a_in, T_a_in, q_a_in, P_a_in, & - - depth_w, fetch_in, depth_bs_in, T_bs_in, par_Coriolis, del_time, & - T_snow_in, T_ice_in, T_mnw_in, T_wML_in, T_bot_in, T_B1_in, & - C_T_in, h_snow_in, h_ice_in, h_ML_in, H_B1_in, T_sfc_in, & - ch_in, cm_in, albedo_water, water_extinc, & -! - T_snow_out, T_ice_out, T_mnw_out, T_wML_out, T_bot_out, & - T_B1_out, C_T_out, h_snow_out, h_ice_out, h_ML_out, & - H_B1_out, T_sfc_out, Q_SHT_flx, Q_watvap, & -! - T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) - -!------------------------------------------------------------------------------ -! Update output and values for previous time step -! - T_snow(i) = T_snow_out - T_ice(i) = T_ice_out - T_mnw(i) = T_mnw_out - T_wML(i) = T_wML_out - T_sfc(i) = T_sfc_out - Tsurf(i) = T_sfc_out - T_bot(i) = T_bot_out - T_B1(i) = T_B1_out - C_T(i) = C_T_out - h_ML(i) = h_ML_out - H_B1(i) = H_B1_out - ustar(i) = u_star - qsfc(i) = q_sfc - chh(i) = chh_out - cmm(i) = cmm_out - snwdph(i) = h_snow_out - hice(i) = h_ice_out - evap(i) = Q_watvap - hflx(i) = Q_SHT_flx - - if(hice(i) .gt. 0.0 .or. snwdph(i) .gt. 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif - enddo !iter loop - endif !endif of lake - endif !endif of flag - - ENDDO - - 125 format(1x,i2,1x,i2,1x,i2,1x,6(1x,f14.8)) - 126 format(1x,i2,1x,i2,1x,6(1x,f14.8)) - 127 format(1x,i2,2(1x,f16.9)) -!------------------------------------------------------------------------------ -! End calculations -!============================================================================== - -END SUBROUTINE flake_driver_run - -!--------------------------------- - end module flake_driver From d80a866c59be55788df5f5c9d3d8c09a09cc4132 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 17:30:45 +0000 Subject: [PATCH 128/165] removing micro_mg3_0.F90_Sep19 --- physics/micro_mg3_0.F90_Sep19 | 4529 --------------------------------- 1 file changed, 4529 deletions(-) delete mode 100644 physics/micro_mg3_0.F90_Sep19 diff --git a/physics/micro_mg3_0.F90_Sep19 b/physics/micro_mg3_0.F90_Sep19 deleted file mode 100644 index 636293b86..000000000 --- a/physics/micro_mg3_0.F90_Sep19 +++ /dev/null @@ -1,4529 +0,0 @@ -!>\file micro_mg3_0.F90 -!! This file contains Morrison-Gettelman MP version 3.0 - -!! Update of MG microphysics with prognostic hail OR graupel. - -!>\ingroup mg2mg3 -!>\defgroup mg3_mp Morrison-Gettelman MP version 3.0 -!> @{ -!!--------------------------------------------------------------------------------- -!! Purpose: -!! MG microphysics version 3.0 - Update of MG microphysics with -!! prognostic hail OR graupel. -!! -!! \authors Andrew Gettelman, Hugh Morrison -!! -!! \version 3 history: Sep 2016: development begun for hail, graupel -!! This version:https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ -!! -!! \version 2 history: Sep 2011: Development begun. -!!\n Feb 2013: Added of prognostic precipitation. -!!\n Aug 2015: Published and released version -!! -!! Contributions from: Sean Santos, Peter Caldwell, Xiaohong Liu and Steve Ghan -!! -!! - Anning Cheng adopted mg2 for FV3GFS 9/29/2017 -!!\n add GMAO ice conversion and Liu et. al liquid water -!!\n conversion in 10/12/2017 -!! -!! - Anning showed promising results for FV3GFS on 10/15/2017 -!! - S. Moorthi - Oct/Nov 2017 - optimized the MG2 code -!! - S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit -!! - S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation -!! other modifications to eliminate blowup. -!! - S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 -!! - S. Moorthi - Oct,29,2018 - change nlb from nlev/3 to levels with p/ps < 0.05 (nlball) -!! -!! invoked in CAM by specifying -microphys=mg3 -!! -!! References: -!! -!! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. -!! Part I: Off line tests and comparisons with other schemes. -!! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. -!! -!! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell -!! Advanced Two-Moment Microphysics for Global Models. -!! 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 -!! controlled by the do_cldice variable. -!! -!! If do_cldice is false, then MG microphysics should not update CLDICE or -!! NUMICE; it is assumed that the other microphysics scheme will have updated -!! CLDICE and NUMICE. The other microphysics should handle the following -!! processes that would have been done by MG: -!! - Detrainment (liquid and ice) -!! - Homogeneous ice nucleation -!! - Heterogeneous ice nucleation -!! - Bergeron process -!! - Melting of ice -!! - Freezing of cloud drops -!! - Autoconversion (ice -> snow) -!! - Growth/Sublimation of ice -!! - Sedimentation of ice -!! -!! This option has not been updated since the introduction of prognostic -!! precipitation, and probably should be adjusted to cover snow as well. -! -!--------------------------------------------------------------------------------- -!Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F -!--------------------------------------------------------------------------------- -! Based on micro_mg (restructuring of former cldwat2m_micro) -! Author: Andrew Gettelman, Hugh Morrison. -! Contributions from: Xiaohong Liu and Steve Ghan -! December 2005-May 2010 -! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) -! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) -! for questions contact Hugh Morrison, Andrew Gettelman -! e-mail: morrison@ucar.edu, andrew@ucar.edu -!--------------------------------------------------------------------------------- -! Code comments added by HM, 093011 -! General code structure: -! -! Code is divided into two main subroutines: -! subroutine micro_mg_init --> initializes microphysics routine, should be called -! once at start of simulation -! subroutine micro_mg_tend --> main microphysics routine to be called each time step -! this also calls several smaller subroutines to calculate -! microphysical processes and other utilities -! -! List of external functions: -! qsat_water --> for calculating saturation vapor pressure with respect to liquid water -! qsat_ice --> for calculating saturation vapor pressure with respect to ice -! gamma --> standard mathematical gamma function -! ......................................................................... -! List of inputs through use statement in fortran90: -! Variable Name Description Units -! ......................................................................... -! gravit acceleration due to gravity m s-2 -! rair dry air gas constant for air J kg-1 K-1 -! tmelt temperature of melting point for water K -! cpair specific heat at constant pressure for dry air J kg-1 K-1 -! rh2o gas constant for water vapor J kg-1 K-1 -! latvap latent heat of vaporization J kg-1 -! latice latent heat of fusion J kg-1 -! qsat_water external function for calculating liquid water -! saturation vapor pressure/humidity - -! qsat_ice external function for calculating ice -! saturation vapor pressure/humidity pa -! rhmini relative humidity threshold parameter for -! nucleating ice - -! ......................................................................... -! NOTE: List of all inputs/outputs passed through the call/subroutine statement -! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. -!--------------------------------------------------------------------------------- - -! Procedures required: -! 1) An implementation of the gamma function (if not intrinsic). -! 2) saturation vapor pressure and specific humidity over water -! 3) svp over ice - -module micro_mg3_0 - -use machine, only : r8 => kind_phys -use funcphys, only : fpvsl, fpvsi - -!use wv_sat_methods, only: & -! qsat_water => wv_sat_qsat_water, & -! qsat_ice => wv_sat_qsat_ice - -! Parameters from the utilities module. -use micro_mg_utils, only : pi, omsm, qsmall, mincld, rhosn, rhoi, & - rhow, rhows, ac, bc, ai, bi, & - aj, bj, ar, br, as, bs, & -!++ag - ag, bg, ah, bh, rhog, rhoh, & -!--ag - mi0, rising_factorial - -implicit none -private -save - -public :: micro_mg_init, micro_mg_tend, qcvar - -! Switches for specification rather than prediction of droplet and crystal number -! note: number will be adjusted as needed to keep mean size within bounds, -! even when specified droplet or ice number is used -! -! If constant cloud ice number is set (nicons = .true.), -! then all microphysical processes except mass transfer due to ice nucleation -! (mnuccd) are based on the fixed cloud ice number. Calculation of -! mnuccd follows from the prognosed ice crystal number ni. - -logical :: nccons !< nccons = .true. to specify constant cloud droplet number -logical :: nicons !< nicons = .true. to specify constant cloud ice number -!++ag kt -logical :: ngcons !< ngcons = .true. to specify constant graupel number -!--ag kt - -! specified ice and droplet number concentrations -! note: these are local in-cloud values, not grid-mean -real(r8) :: ncnst !< droplet num concentration when nccons=.true. (m-3) -real(r8) :: ninst !< ice num concentration when nicons=.true. (m-3) -!++ag kt -real(r8) :: ngnst !< graupel num concentration when ngcons=.true. (m-3) -!--ag kt - -!========================================================= -! Private module parameters -!========================================================= - -!> Range of cloudsat reflectivities (dBz) for analytic simulator -real(r8), parameter :: csmin = -30._r8 -real(r8), parameter :: csmax = 26._r8 -real(r8), parameter :: mindbz = -99._r8 -real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) - -! autoconversion size threshold for cloud ice to snow (m) -real(r8) :: dcs, ts_au, ts_au_min, qcvar - -! minimum mass of new crystal due to freezing of cloud droplets done -! externally (kg) -real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 - -! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. -real(r8), parameter :: sublim_factor = 0.0_r8 !number sublimation factor. - -real(r8), parameter :: zero=0.0_r8, one=1.0_r8, two=2.0_r8, three=3.0_r8, & - four=4.0_r8, five=5.0_r8, six=6._r8, half=0.5_r8, & - ten=10.0_r8, forty=40.0_r8, oneo6=one/six - -!========================================================= -! Constants set in initialization -!========================================================= - -! Set using arguments to micro_mg_init -real(r8) :: g !< gravity -real(r8) :: r !< dry air gas constant -real(r8) :: rv !< water vapor gas constant -real(r8) :: cpp !< specific heat of dry air -real(r8) :: tmelt !< freezing point of water (K) - -! latent heats of: -real(r8) :: xxlv !< vaporization -real(r8) :: xlf !< freezing -real(r8) :: xxls !< sublimation - -real(r8) :: rhmini !< Minimum rh for ice cloud fraction > 0. - -! flags -logical :: microp_uniform, do_cldice, use_hetfrz_classnuc, & -!++ag - do_hail, do_graupel -!--ag - -real(r8) :: rhosu !< typical 850mn air density - -real(r8) :: icenuct !< ice nucleation temperature: currently -5 degrees C - -real(r8) :: snowmelt !< what temp to melt all snow: currently 2 degrees C -real(r8) :: rainfrze !< what temp to freeze all rain: currently -5 degrees C - -real(r8) :: rhogtmp !< hail or graupel density (kg m-3) -real(r8) :: agtmp !< tmp ag/ah parameter -real(r8) :: bgtmp !< tmp fall speed parameter - -! additional constants to help speed up code -real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1, gamma_bg_plus1 -real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4, gamma_bg_plus4 -real(r8) :: xxlv_squared, xxls_squared -real(r8) :: omeps, epsqs - -character(len=16) :: micro_mg_precip_frac_method !< type of precipitation fraction method -real(r8) :: micro_mg_berg_eff_factor !< berg efficiency factor - -logical :: allow_sed_supersat !< Allow supersaturated conditions after sedimentation loop -logical :: do_sb_physics !< do SB 2001 autoconversion or accretion physics -logical :: do_ice_gmao -logical :: do_liq_liu - -!=============================================================================== -contains -!=============================================================================== - -!>\ingroup mg3_mp -!! This subroutine initializes the microphysics -!! and needs to be called once at start of simulation. -!!\author Andrew Gettelman, Dec 2005 -subroutine micro_mg_init( & - kind, gravit, rair, rh2o, cpair, eps, & - tmelt_in, latvap, latice, & - rhmini_in, micro_mg_dcs,ts_auto, mg_qcvar, & -!++ag - micro_mg_do_hail_in, micro_mg_do_graupel_in, & -!--ag - microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & - micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & - allow_sed_supersat_in, do_sb_physics_in, & - do_ice_gmao_in, do_liq_liu_in, & - nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in) -! nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, errstring) - - use micro_mg_utils, only : micro_mg_utils_init - use wv_saturation, only : gestbl - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! initialize constants for MG microphysics - ! - ! Author: Andrew Gettelman Dec 2005 - ! - !----------------------------------------------------------------------- - - 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) :: eps -! real(r8), intent(in) :: fv - 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) :: 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) -!--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 - - 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 - - logical, intent(in) :: nccons_in, nicons_in, ngcons_in - real(r8), intent(in) :: ncnst_in, ninst_in, ngnst_in - logical ip - real(r8):: tmn, tmx, trice - - -! character(128), intent(out) :: errstring ! Output status (non-blank for error return) - - !----------------------------------------------------------------------- - - dcs = micro_mg_dcs * 1.0e-6_r8 - ts_au_min = ts_auto(1) - ts_au = ts_auto(2) - qcvar = mg_qcvar - - ! Initialize subordinate utilities module. - call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & - dcs) -! dcs, errstring) - -! if (trim(errstring) /= "") return - - ! declarations for MG code (transforms variable names) - - g = gravit ! gravity - r = rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) -! write(0,*)' in micro_mg_utils_init=',' r=',r,' rair=',rair,' rh2o=',rh2o - rv = rh2o ! water vapor gas constant - cpp = cpair ! specific heat of dry air - tmelt = tmelt_in - rhmini = rhmini_in - micro_mg_precip_frac_method = micro_mg_precip_frac_method_in - micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in - allow_sed_supersat = allow_sed_supersat_in - do_sb_physics = do_sb_physics_in - do_ice_gmao = do_ice_gmao_in - do_liq_liu = do_liq_liu_in - - nccons = nccons_in - nicons = nicons_in - ncnst = ncnst_in - ninst = ninst_in -!++ag - ngcons = ngcons_in - ngnst = ngnst_in -!--ag - - ! latent heats - - xxlv = latvap ! latent heat vaporization - xlf = latice ! latent heat freezing - xxls = xxlv + xlf ! latent heat of sublimation - - ! flags - microp_uniform = microp_uniform_in - do_cldice = do_cldice_in - use_hetfrz_classnuc = use_hetfrz_classnuc_in -!++ag - do_hail = micro_mg_do_hail_in - do_graupel = micro_mg_do_graupel_in -! - if (do_hail) then - agtmp = ah - bgtmp = bh - rhogtmp = rhoh - elseif (do_graupel) then - agtmp = ag - bgtmp = bg - rhogtmp = rhog - else - agtmp = zero - bgtmp = zero - endif -!--ag - - ! typical air density at 850 mb - - rhosu = 85000._r8 / (rair * tmelt) - - ! Maximum temperature at which snow is allowed to exist - snowmelt = tmelt + two - ! Minimum temperature at which rain is allowed to exist - rainfrze = tmelt - forty - - ! Ice nucleation temperature - icenuct = tmelt - five - - ! Define constants to help speed up code (this limits calls to gamma function) - gamma_br_plus1 = gamma(br+one) - gamma_br_plus4 = gamma(br+four) - gamma_bs_plus1 = gamma(bs+one) - gamma_bs_plus4 = gamma(bs+four) - gamma_bi_plus1 = gamma(bi+one) - gamma_bi_plus4 = gamma(bi+four) - gamma_bj_plus1 = gamma(bj+one) - gamma_bj_plus4 = gamma(bj+four) -! - gamma_bg_plus1 = gamma(bgtmp+one) - gamma_bg_plus4 = gamma(bgtmp+four) - - xxlv_squared = xxlv * xxlv - xxls_squared = xxls * xxls - epsqs = eps - omeps = one - epsqs - tmn = 173.16_r8 - tmx = 375.16_r8 - trice = 35.00_r8 - ip = .true. -!> - call gestbl() - call gestbl(tmn ,tmx ,trice ,ip ,epsqs , latvap ,latice ,rh2o , & - cpair ,tmelt_in ) - - - -end subroutine micro_mg_init - -!=============================================================================== -!microphysics routine for each timestep goes here... - -!>\ingroup mg3_mp -!! This subroutine calculates the MG3 microphysical processes. -!>\authors Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL -!! e-mail: morrison@ucar.edu, andrew@ucar.edu -!!\section mg3_micro_mg_tend MG3 micro_mg_tend General Algorithm -!> @{ -subroutine micro_mg_tend ( & - mgncol, nlev, deltatin, & - t, q, & - qcn, qin, & - ncn, nin, & - qrn, qsn, & - nrn, nsn, & -!++ag - qgr, ngr, & -!--ag - relvar, accre_enhan_i, & - p, pdel, & - cldn, liqcldf, icecldf, qsatfac, & - qcsinksum_rate1ord, & - naai, npccnin, & - rndst, nacon, & - tlat, qvlat, & - qctend, qitend, & - nctend, nitend, & - qrtend, qstend, & - nrtend, nstend, & -!++ag - qgtend, ngtend, & -!--ag - effc, effc_fn, effi, & - sadice, sadsnow, & - prect, preci, & - nevapr, evapsnow, & - am_evp_st, & - prain, prodsnow, & - cmeout, deffi, & - pgamrad, lamcrad, & - qsout, dsout, & -!++ag - qgout, ngout, dgout, & -!--ag - lflx, iflx, & -!++ag - gflx, & -!--ag - rflx, sflx, qrout, & -!++ag - reff_rain, reff_snow, reff_grau, & -!--ag - - qcsevap, qisevap, qvres, & - cmeitot, vtrmc, vtrmi, & - umr, ums, & -!++ag - umg, qgsedten, & -!--ag - qcsedten, qisedten, & - qrsedten, qssedten, & - pratot, prctot, & - mnuccctot, mnuccttot, msacwitot, & - psacwstot, bergstot, bergtot, & - melttot, homotot, & - qcrestot, prcitot, praitot, & -!++ag - qirestot, mnuccrtot, mnuccritot, pracstot, & -!--ag - meltsdttot, frzrdttot, mnuccdtot, & -!++ag - pracgtot, psacwgtot, pgsacwtot, & - pgracstot, prdgtot, & - qmultgtot, qmultrgtot, psacrtot, & - npracgtot, nscngtot, ngracstot, & - nmultgtot, nmultrgtot, npsacwgtot, & -!--ag - nrout, nsout, & - refl, arefl, areflz, & - frefl, csrfl, acsrfl, & - fcsrfl, rercld, & - ncai, ncal, & - qrout2, qsout2, & - nrout2, nsout2, & - drout2, dsout2, & -!++ag - qgout2, ngout2, dgout2, freqg, & -!--ag - freqs, freqr, & - nfice, qcrat, & - prer_evap, xlat, xlon, lprnt, iccn, nlball) - - ! Constituent properties. - use micro_mg_utils, only: mg_liq_props, & - mg_ice_props, & - mg_rain_props, & -!++ag - mg_graupel_props,& -!--ag - mg_snow_props - - ! Size calculation functions. - use micro_mg_utils, only: size_dist_param_liq, & - size_dist_param_basic, & - avg_diameter - - ! Microphysical processes. - use micro_mg_utils, only: ice_deposition_sublimation, & - sb2001v2_liq_autoconversion, & - sb2001v2_accre_cld_water_rain, & - kk2000_liq_autoconversion, & - ice_autoconversion, & - immersion_freezing, & - contact_freezing, & - snow_self_aggregation, & - accrete_cloud_water_snow, & - secondary_ice_production, & - accrete_rain_snow, & - heterogeneous_rain_freezing, & - accrete_cloud_water_rain, & - self_collection_rain, & - accrete_cloud_ice_snow, & - evaporate_sublimate_precip, & - bergeron_process_snow, & - size_dist_param_ice, & -!++ag - graupel_collecting_snow, & - graupel_collecting_rain, & - graupel_collecting_cld_water, & - graupel_riming_liquid_snow, & - graupel_rain_riming_snow, & - graupel_rime_splintering, & - evaporate_sublimate_precip_graupel,& -! graupel_sublimate_evap -!--ag - liu_liq_autoconversion, & - gmao_ice_autoconversion - - !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL - ! e-mail: morrison@ucar.edu, andrew@ucar.edu - - ! input arguments - integer, intent(in) :: mgncol !< number of microphysics columns - integer, intent(in) :: nlev !< number of layers - integer, intent(in) :: nlball(mgncol) !< sedimentation start level - real(r8), intent(in) :: xlat,xlon !< number of layers - real(r8), intent(in) :: deltatin !< time step (s) - real(r8), intent(in) :: t(mgncol,nlev) !< input temperature (K) - real(r8), intent(in) :: q(mgncol,nlev) !< input h20 vapor mixing ratio (kg/kg) - - ! note: all input cloud variables are grid-averaged - real(r8), intent(in) :: qcn(mgncol,nlev) !< cloud water mixing ratio (kg/kg) - real(r8), intent(in) :: qin(mgncol,nlev) !< cloud ice mixing ratio (kg/kg) - real(r8), intent(in) :: ncn(mgncol,nlev) !< cloud water number conc (1/kg) - real(r8), intent(in) :: nin(mgncol,nlev) !< cloud ice number conc (1/kg) - - real(r8), intent(in) :: qrn(mgncol,nlev) !< rain mixing ratio (kg/kg) - real(r8), intent(in) :: qsn(mgncol,nlev) !< snow mixing ratio (kg/kg) - real(r8), intent(in) :: nrn(mgncol,nlev) !< rain number conc (1/kg) - real(r8), intent(in) :: nsn(mgncol,nlev) !< snow number conc (1/kg) -!++ag - real(r8), intent(in) :: qgr(mgncol,nlev) !< graupel/hail mixing ratio (kg/kg) - real(r8), intent(in) :: ngr(mgncol,nlev) !< graupel/hail number conc (1/kg) -!--ag - - real(r8) :: relvar(mgncol,nlev) !< cloud water relative variance (-) - real(r8) :: accre_enhan(mgncol,nlev)!< optional accretion -! real(r8), intent(in) :: relvar_i !< cloud water relative variance (-) - real(r8), intent(in) :: accre_enhan_i !< optional accretion - !< enhancement factor (-) - - real(r8), intent(in) :: p(mgncol,nlev) !< air pressure (pa) - real(r8), intent(in) :: pdel(mgncol,nlev) !< pressure difference across level (pa) - - real(r8), intent(in) :: cldn(mgncol,nlev) !< cloud fraction (no units) - 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 !< control flag for diagnostic print out - integer, intent(in) :: iccn !< flag for IN and CCN forcing for Morrison-Gettelman microphysics - - - ! used for scavenging - ! Inputs for aerosol activation - real(r8), intent(inout) :: naai(mgncol,nlev) !< ice nucleation number (from microp_aero_ts) (1/kg) - real(r8), intent(in) :: npccnin(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) -! real(r8), intent(in) :: npccn(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) - real(r8) :: npccn(mgncol,nlev) !< ccn activated number tendency (from microp_aero_ts) (1/kg*s) - - ! Note that for these variables, the dust bin is assumed to be the last index. - ! (For example, in CAM, the last dimension is always size 4.) - real(r8), intent(in) :: rndst(mgncol,nlev,10) !< radius of each dust bin, for contact freezing (from microp_aero_ts) (m) - real(r8), intent(in) :: nacon(mgncol,nlev,10) !< number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - - ! output arguments - - real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) !< 1st order rate for - !! direct cw to precip conversion - real(r8), intent(out) :: tlat(mgncol,nlev) !< latent heating rate (W/kg) - real(r8), intent(out) :: qvlat(mgncol,nlev) !< microphysical tendency qv (1/s) - real(r8), intent(out) :: qctend(mgncol,nlev) !< microphysical tendency qc (1/s) - real(r8), intent(out) :: qitend(mgncol,nlev) !< microphysical tendency qi (1/s) - real(r8), intent(out) :: nctend(mgncol,nlev) !< microphysical tendency nc (1/(kg*s)) - real(r8), intent(out) :: nitend(mgncol,nlev) !< microphysical tendency ni (1/(kg*s)) - - real(r8), intent(out) :: qrtend(mgncol,nlev) !< microphysical tendency qr (1/s) - real(r8), intent(out) :: qstend(mgncol,nlev) !< microphysical tendency qs (1/s) - real(r8), intent(out) :: nrtend(mgncol,nlev) !< microphysical tendency nr (1/(kg*s)) - real(r8), intent(out) :: nstend(mgncol,nlev) !< microphysical tendency ns (1/(kg*s)) -!++ag - real(r8), intent(out) :: qgtend(mgncol,nlev) !< microphysical tendency qg (1/s) - real(r8), intent(out) :: ngtend(mgncol,nlev) !< microphysical tendency ng (1/(kg*s)) -!--ag - real(r8), intent(out) :: effc(mgncol,nlev) !< droplet effective radius (micron) - real(r8), intent(out) :: effc_fn(mgncol,nlev) !< droplet effective radius, assuming nc = 1.e8 kg-1 - real(r8), intent(out) :: effi(mgncol,nlev) !< cloud ice effective radius (micron) - real(r8), intent(out) :: sadice(mgncol,nlev) !< cloud ice surface area density (cm2/cm3) - real(r8), intent(out) :: sadsnow(mgncol,nlev) !< cloud snow surface area density (cm2/cm3) - real(r8), intent(out) :: prect(mgncol) !< surface precip rate (m/s) - real(r8), intent(out) :: preci(mgncol) !< cloud ice/snow precip rate (m/s) - real(r8), intent(out) :: nevapr(mgncol,nlev) !< evaporation rate of rain + snow (1/s) - real(r8), intent(out) :: evapsnow(mgncol,nlev) !< sublimation rate of snow (1/s) - real(r8), intent(out) :: am_evp_st(mgncol,nlev) !< stratiform evaporation area (frac) - real(r8), intent(out) :: prain(mgncol,nlev) !< production of rain + snow (1/s) - real(r8), intent(out) :: prodsnow(mgncol,nlev) !< production of snow (1/s) - real(r8), intent(out) :: cmeout(mgncol,nlev) !< evap/sub of cloud (1/s) - real(r8), intent(out) :: deffi(mgncol,nlev) !< ice effective diameter for optics (radiation) (micron) - real(r8), intent(out) :: pgamrad(mgncol,nlev) !< ice gamma parameter for optics (radiation) (no units) - real(r8), intent(out) :: lamcrad(mgncol,nlev) !< slope of droplet distribution for optics (radiation) (1/m) - real(r8), intent(out) :: qsout(mgncol,nlev) !< snow mixing ratio (kg/kg) - real(r8), intent(out) :: dsout(mgncol,nlev) !< snow diameter (m) - real(r8), intent(out) :: lflx(mgncol,2:nlev+1) !< grid-box average liquid condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: iflx(mgncol,2:nlev+1) !< grid-box average ice condensate flux (kg m^-2 s^-1) - real(r8), intent(out) :: rflx(mgncol,2:nlev+1) !< grid-box average rain flux (kg m^-2 s^-1) - real(r8), intent(out) :: sflx(mgncol,2:nlev+1) !< grid-box average snow flux (kg m^-2 s^-1) -!++ag - real(r8), intent(out) :: gflx(mgncol,2:nlev+1) !< grid-box average graupel/hail flux (kg m^-2 s^-1) -!--ag - real(r8), intent(out) :: qrout(mgncol,nlev) !< grid-box average rain mixing ratio (kg/kg) - real(r8), intent(out) :: reff_rain(mgncol,nlev) !< rain effective radius (micron) - real(r8), intent(out) :: reff_snow(mgncol,nlev) !< snow effective radius (micron) -!++ag - real(r8), intent(out) :: reff_grau(mgncol,nlev) !< graupel effective radius (micron) -!--ag - real(r8), intent(out) :: qcsevap(mgncol,nlev) !< cloud water evaporation due to sedimentation (1/s) - real(r8), intent(out) :: qisevap(mgncol,nlev) !< cloud ice sublimation due to sedimentation (1/s) - real(r8), intent(out) :: qvres(mgncol,nlev) !< residual condensation term to ensure RH < 100% (1/s) - real(r8), intent(out) :: cmeitot(mgncol,nlev) !< grid-mean cloud ice sub/dep (1/s) - real(r8), intent(out) :: vtrmc(mgncol,nlev) !< mass-weighted cloud water fallspeed (m/s) - real(r8), intent(out) :: vtrmi(mgncol,nlev) !< mass-weighted cloud ice fallspeed (m/s) - real(r8), intent(out) :: umr(mgncol,nlev) !< mass weighted rain fallspeed (m/s) - real(r8), intent(out) :: ums(mgncol,nlev) !< mass weighted snow fallspeed (m/s) -!++ag - real(r8), intent(out) :: umg(mgncol,nlev) !< mass weighted graupel/hail fallspeed (m/s) - real(r8), intent(out) :: qgsedten(mgncol,nlev) !< qg sedimentation tendency (1/s) -!--ag - - real(r8), intent(out) :: qcsedten(mgncol,nlev) !< qc sedimentation tendency (1/s) - real(r8), intent(out) :: qisedten(mgncol,nlev) !< qi sedimentation tendency (1/s) - real(r8), intent(out) :: qrsedten(mgncol,nlev) !< qr sedimentation tendency (1/s) - real(r8), intent(out) :: qssedten(mgncol,nlev) !< qs sedimentation tendency (1/s) - - ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) - real(r8), intent(out) :: pratot(mgncol,nlev) !< accretion of cloud by rain - real(r8), intent(out) :: prctot(mgncol,nlev) !< autoconversion of cloud to rain - real(r8), intent(out) :: mnuccctot(mgncol,nlev) !< mixing ratio tend due to immersion freezing - real(r8), intent(out) :: mnuccttot(mgncol,nlev) !< mixing ratio tend due to contact freezing - real(r8), intent(out) :: msacwitot(mgncol,nlev) !< mixing ratio tend due to H-M splintering - real(r8), intent(out) :: psacwstot(mgncol,nlev) !< collection of cloud water by snow - real(r8), intent(out) :: bergstot(mgncol,nlev) !< bergeron process on snow - real(r8), intent(out) :: bergtot(mgncol,nlev) !< bergeron process on cloud ice - real(r8), intent(out) :: melttot(mgncol,nlev) !< melting of cloud ice - real(r8), intent(out) :: homotot(mgncol,nlev) !< homogeneous freezing cloud water - real(r8), intent(out) :: qcrestot(mgncol,nlev) !< residual cloud condensation due to removal of excess supersat - real(r8), intent(out) :: prcitot(mgncol,nlev) !< autoconversion of cloud ice to snow - real(r8), intent(out) :: praitot(mgncol,nlev) !< accretion of cloud ice by snow - real(r8), intent(out) :: qirestot(mgncol,nlev) !< residual ice deposition due to removal of excess supersat - real(r8), intent(out) :: mnuccrtot(mgncol,nlev) !< mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) - real(r8), intent(out) :: mnuccritot(mgncol,nlev)!< mixing ratio tendency due to heterogeneous freezing of rain to ice (1/s) - real(r8), intent(out) :: pracstot(mgncol,nlev) !< mixing ratio tendency due to accretion of rain by snow (1/s) - real(r8), intent(out) :: meltsdttot(mgncol,nlev)!< latent heating rate due to melting of snow (W/kg) - real(r8), intent(out) :: frzrdttot(mgncol,nlev) !< latent heating rate due to homogeneous freezing of rain (W/kg) - real(r8), intent(out) :: mnuccdtot(mgncol,nlev) !< mass tendency from ice nucleation -!++ag Hail/Graupel Tendencies - real(r8), intent(out) :: pracgtot(mgncol,nlev) !< change in q collection rain by graupel (precipf) - real(r8), intent(out) :: psacwgtot(mgncol,nlev) !< change in q collection droplets by graupel (lcldm) - real(r8), intent(out) :: pgsacwtot(mgncol,nlev) !< conversion q to graupel due to collection droplets by snow (lcldm) - real(r8), intent(out) :: pgracstot(mgncol,nlev) !< conversion q to graupel due to collection rain by snow (precipf) - real(r8), intent(out) :: prdgtot(mgncol,nlev) !< dep of graupel (precipf) -! real(r8), intent(out) :: eprdgtot(mgncol,nlev) !< sub of graupel (precipf) - real(r8), intent(out) :: qmultgtot(mgncol,nlev) !< change q due to ice mult droplets/graupel (lcldm) - real(r8), intent(out) :: qmultrgtot(mgncol,nlev)!< change q due to ice mult rain/graupel (precipf) - real(r8), intent(out) :: psacrtot(mgncol,nlev) !< conversion due to coll of snow by rain (precipf) - real(r8), intent(out) :: npracgtot(mgncol,nlev) !< change n collection rain by graupel (precipf) - real(r8), intent(out) :: nscngtot(mgncol,nlev) !< change n conversion to graupel due to collection droplets by snow (lcldm) - real(r8), intent(out) :: ngracstot(mgncol,nlev) !< change n conversion to graupel due to collection rain by snow (precipf) - real(r8), intent(out) :: nmultgtot(mgncol,nlev) !< ice mult due to acc droplets by graupel (lcldm) - real(r8), intent(out) :: nmultrgtot(mgncol,nlev)!< ice mult due to acc rain by graupel (precipf) - real(r8), intent(out) :: npsacwgtot(mgncol,nlev)!< change n collection droplets by graupel (lcldm?) -!--ag - real(r8), intent(out) :: nrout(mgncol,nlev) !< rain number concentration (1/m3) - real(r8), intent(out) :: nsout(mgncol,nlev) !< snow number concentration (1/m3) - real(r8), intent(out) :: refl(mgncol,nlev) !< analytic radar reflectivity - real(r8), intent(out) :: arefl(mgncol,nlev) !< average reflectivity will zero points outside valid range - real(r8), intent(out) :: areflz(mgncol,nlev) !< average reflectivity in z. - real(r8), intent(out) :: frefl(mgncol,nlev) !< fractional occurrence of radar reflectivity - real(r8), intent(out) :: csrfl(mgncol,nlev) !< cloudsat reflectivity - real(r8), intent(out) :: acsrfl(mgncol,nlev) !< cloudsat average - real(r8), intent(out) :: fcsrfl(mgncol,nlev) !< cloudsat fractional occurrence of radar reflectivity - real(r8), intent(out) :: rercld(mgncol,nlev) !< effective radius calculation for rain + cloud - real(r8), intent(out) :: ncai(mgncol,nlev) !< output number conc of ice nuclei available (1/m3) - real(r8), intent(out) :: ncal(mgncol,nlev) !< output number conc of CCN (1/m3) - real(r8), intent(out) :: qrout2(mgncol,nlev) !< copy of qrout as used to compute drout2 - real(r8), intent(out) :: qsout2(mgncol,nlev) !< copy of qsout as used to compute dsout2 - real(r8), intent(out) :: nrout2(mgncol,nlev) !< copy of nrout as used to compute drout2 - real(r8), intent(out) :: nsout2(mgncol,nlev) !< copy of nsout as used to compute dsout2 - real(r8), intent(out) :: drout2(mgncol,nlev) !< mean rain particle diameter (m) - real(r8), intent(out) :: dsout2(mgncol,nlev) !< mean snow particle diameter (m) - real(r8), intent(out) :: freqs(mgncol,nlev) !< fractional occurrence of snow - real(r8), intent(out) :: freqr(mgncol,nlev) !< fractional occurrence of rain - real(r8), intent(out) :: nfice(mgncol,nlev) !< fractional occurrence of ice - real(r8), intent(out) :: qcrat(mgncol,nlev) !< limiter for qc process rates (1=no limit --> 0. no qc) -!++ag - real(r8), intent(out) :: qgout(mgncol,nlev) !< graupel/hail mixing ratio (kg/kg) - real(r8), intent(out) :: dgout(mgncol,nlev) !< graupel/hail diameter (m) - real(r8), intent(out) :: ngout(mgncol,nlev) !< graupel/hail number concentration (1/m3) -!Not sure if these are needed since graupel/hail is prognostic? - real(r8), intent(out) :: qgout2(mgncol,nlev) !< copy of qgout as used to compute dgout2 - real(r8), intent(out) :: ngout2(mgncol,nlev) !< copy of ngout as used to compute dgout2 - real(r8), intent(out) :: dgout2(mgncol,nlev) !< mean graupel/hail particle diameter (m) - real(r8), intent(out) :: freqg(mgncol,nlev) !< fractional occurrence of graupel - -!--ag - - real(r8), intent(out) :: prer_evap(mgncol,nlev) - - - ! Tendencies calculated by external schemes that can replace MG's native - ! process tendencies. - - ! Used with CARMA cirrus microphysics - ! (or similar external microphysics model) - ! real(r8), intent(in) :: tnd_qsnow(:,:) !< snow mass tendency (kg/kg/s) - ! real(r8), intent(in) :: tnd_nsnow(:,:) !< snow number tendency (#/kg/s) - ! real(r8), intent(in) :: re_ice(:,:) !< ice effective radius (m) - - ! From external ice nucleation. - !real(r8), intent(in) :: frzimm(:,:) !< Number tendency due to immersion freezing (1/cm3) - !real(r8), intent(in) :: frzcnt(:,:) !< Number tendency due to contact freezing (1/cm3) - !real(r8), intent(in) :: frzdep(:,:) !< Number tendency due to deposition nucleation (1/cm3) - - ! local workspace - ! all units mks unless otherwise stated - - ! local copies of input variables - real(r8) :: qc(mgncol,nlev) !< cloud liquid mixing ratio (kg/kg) - real(r8) :: qi(mgncol,nlev) !< cloud ice mixing ratio (kg/kg) - real(r8) :: nc(mgncol,nlev) !< cloud liquid number concentration (1/kg) - real(r8) :: ni(mgncol,nlev) !< cloud liquid number concentration (1/kg) - real(r8) :: qr(mgncol,nlev) !< rain mixing ratio (kg/kg) - real(r8) :: qs(mgncol,nlev) !< snow mixing ratio (kg/kg) - real(r8) :: nr(mgncol,nlev) !< rain number concentration (1/kg) - real(r8) :: ns(mgncol,nlev) !< snow number concentration (1/kg) -!++ag - real(r8) :: qg(mgncol,nlev) !< graupel mixing ratio (kg/kg) - real(r8) :: ng(mgncol,nlev) !< graupel number concentration (1/kg) -! real(r8) :: rhogtmp !< hail or graupel density (kg m-3) - -!--ag - - ! general purpose variables - real(r8) :: deltat !< sub-time step (s) - real(r8) :: oneodt !< one / deltat - real(r8) :: mtime !< the assumed ice nucleation timescale - - ! physical properties of the air at a given point - real(r8) :: rho(mgncol,nlev) ! density (kg m-3) - real(r8) :: rhoinv(mgncol,nlev) ! one / density (kg m-3) - real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor - real(r8) :: mu(mgncol,nlev) ! viscosity - real(r8) :: sc(mgncol,nlev) ! schmidt number - real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed - - ! cloud fractions - real(r8) :: precip_frac(mgncol,nlev)! precip fraction assuming maximum overlap - real(r8) :: cldm(mgncol,nlev) ! cloud fraction - real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction - real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction - real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor - - ! mass mixing ratios - real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid - real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: qsic(mgncol,nlev) ! in-precip snow - real(r8) :: qric(mgncol,nlev) ! in-precip rain -!++ag - real(r8) :: qgic(mgncol,nlev) ! in-precip graupel/hail -!++ag - - - ! number concentrations - real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet - real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice - real(r8) :: nsic(mgncol,nlev) ! in-precip snow - real(r8) :: nric(mgncol,nlev) ! in-precip rain -!++ag - real(r8) :: ngic(mgncol,nlev) ! in-precip graupel/hail -!++ag - - ! maximum allowed ni value - real(r8) :: nimax(mgncol,nlev) - - ! Size distribution parameters for: - ! cloud ice - real(r8) :: lami(mgncol,nlev) ! slope - real(r8) :: n0i(mgncol,nlev) ! intercept - ! cloud liquid - real(r8) :: lamc(mgncol,nlev) ! slope - real(r8) :: pgam(mgncol,nlev) ! spectral width parameter - ! snow - real(r8) :: lams(mgncol,nlev) ! slope - real(r8) :: n0s(mgncol,nlev) ! intercept - ! rain - real(r8) :: lamr(mgncol,nlev) ! slope - real(r8) :: n0r(mgncol,nlev) ! intercept -!++ag - ! graupel/hail - real(r8) :: lamg(mgncol,nlev) ! slope - real(r8) :: n0g(mgncol,nlev) ! intercept -! real(r8) :: bgtmp ! tmp fall speed parameter -!--ag - - ! Rates/tendencies due to: - - ! Instantaneous snow melting - real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstsm(mgncol,nlev) ! number concentration -!++ag - ! Instantaneous graupel melting - real(r8) :: minstgm(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstgm(mgncol,nlev) ! number concentration -!--ag - - ! Instantaneous rain freezing - real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio - real(r8) :: ninstrf(mgncol,nlev) ! number concentration - - ! deposition of cloud ice - real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 - ! sublimation of cloud ice - real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 - ! ice nucleation - real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing - real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio - ! freezing of cloud water - real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccc(mgncol,nlev) ! number concentration - ! contact freezing of cloud water - real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnucct(mgncol,nlev) ! number concentration - ! deposition nucleation in mixed-phase clouds (from external scheme) - real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnudep(mgncol,nlev) ! number concentration - ! ice multiplication - real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio - real(r8) :: nsacwi(mgncol,nlev) ! number concentration - ! autoconversion of cloud droplets - real(r8) :: prc(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) - real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) - ! self-aggregation of snow - real(r8) :: nsagg(mgncol,nlev) ! number concentration - ! self-collection of rain - real(r8) :: nragg(mgncol,nlev) ! number concentration - ! collection of droplets by snow - real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio - real(r8) :: npsacws(mgncol,nlev) ! number concentration - ! collection of rain by snow - real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio - real(r8) :: npracs(mgncol,nlev) ! number concentration - ! freezing of rain - real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccr(mgncol,nlev) ! number concentration - ! freezing of rain to form ice (mg add 4/26/13) - real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio - real(r8) :: nnuccri(mgncol,nlev) ! number concentration - ! accretion of droplets by rain - real(r8) :: pra(mgncol,nlev) ! mass mixing ratio - real(r8) :: npra(mgncol,nlev) ! number concentration - ! autoconversion of cloud ice to snow - real(r8) :: prci(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprci(mgncol,nlev) ! number concentration - ! accretion of cloud ice by snow - real(r8) :: prai(mgncol,nlev) ! mass mixing ratio - real(r8) :: nprai(mgncol,nlev) ! number concentration - ! evaporation of rain - real(r8) :: pre(mgncol,nlev) ! mass mixing ratio - ! sublimation of snow - real(r8) :: prds(mgncol,nlev) ! mass mixing ratio - ! number evaporation - real(r8) :: nsubi(mgncol,nlev) ! cloud ice - real(r8) :: nsubc(mgncol,nlev) ! droplet - real(r8) :: nsubs(mgncol,nlev) ! snow - real(r8) :: nsubr(mgncol,nlev) ! rain - ! bergeron process - real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) - real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) - -!++ag - !graupel/hail processes - real(r8) :: npracg(mgncol,nlev) ! change n collection rain by graupel (precipf) - real(r8) :: nscng(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) - real(r8) :: ngracs(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) - real(r8) :: nmultg(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) - real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel (precipf) - real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm) - - real(r8) :: psacr(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) - real(r8) :: pracg(mgncol,nlev) ! change in q collection rain by graupel (precipf) - real(r8) :: psacwg(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) - real(r8) :: pgsacw(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) - real(r8) :: pgracs(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) - real(r8) :: prdg(mgncol,nlev) ! dep of graupel (precipf) -! real(r8) :: eprdg(mgncol,nlev) ! evap/sub of graupel (precipf) - real(r8) :: qmultg(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) - real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf) -!--ag - - - ! fallspeeds - ! number-weighted - real(r8) :: uns(mgncol,nlev) ! snow - real(r8) :: unr(mgncol,nlev) ! rain -!++ag - real(r8) :: ung(mgncol,nlev) ! graupel/hail -!--ag - ! air density corrected fallspeed parameters - real(r8) :: arn(mgncol,nlev) ! rain - real(r8) :: asn(mgncol,nlev) ! snow -!++a - real(r8) :: agn(mgncol,nlev) ! graupel -!--ag - real(r8) :: acn(mgncol,nlev) ! cloud droplet - real(r8) :: ain(mgncol,nlev) ! cloud ice - real(r8) :: ajn(mgncol,nlev) ! cloud small ice - - ! Mass of liquid droplets used with external heterogeneous freezing. - real(r8) :: mi0l(mgncol) - - ! saturation vapor pressures - real(r8) :: esl(mgncol,nlev) ! liquid - real(r8) :: esi(mgncol,nlev) ! ice - real(r8) :: esn ! checking for RH after rain evap - - ! saturation vapor mixing ratios - real(r8) :: qvl(mgncol,nlev) ! liquid - real(r8) :: qvi(mgncol,nlev) ! ice - real(r8) :: qvn ! checking for RH after rain evap - - ! relative humidity - real(r8) :: relhum(mgncol,nlev) - - ! parameters for cloud water and cloud ice sedimentation calculations - real(r8) :: fc(mgncol,nlev) - real(r8) :: fnc(mgncol,nlev) - real(r8) :: fi(mgncol,nlev) - real(r8) :: fni(mgncol,nlev) - -!++ag - real(r8) :: fg(mgncol,nlev) - real(r8) :: fng(mgncol,nlev) -!--ag - - real(r8) :: fr(mgncol,nlev) - real(r8) :: fnr(mgncol,nlev) - real(r8) :: fs(mgncol,nlev) - real(r8) :: fns(mgncol,nlev) - - real(r8) :: faloutc(nlev) - real(r8) :: faloutnc(nlev) - real(r8) :: falouti(nlev) - real(r8) :: faloutni(nlev) - - real(r8) :: faloutr(nlev) - real(r8) :: faloutnr(nlev) - real(r8) :: falouts(nlev) - real(r8) :: faloutns(nlev) - - real(r8) :: faltndc - real(r8) :: faltndnc - real(r8) :: faltndi - real(r8) :: faltndni - real(r8) :: faltndqie - real(r8) :: faltndqce - - real(r8) :: faltndr - real(r8) :: faltndnr - real(r8) :: faltnds - real(r8) :: faltndns - -!++ag - real(r8) :: faloutg(nlev) - real(r8) :: faloutng(nlev) - real(r8) :: faltndg - real(r8) :: faltndng -!--ag - - real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation - - ! dummy variables - real(r8) :: dum - real(r8) :: dum1 - real(r8) :: dum2 -!++ag - real(r8) :: dum3 -!--ag - real(r8) :: dumni0 - real(r8) :: dumns0 - real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho - ! dummies for checking RH - real(r8) :: qtmp - real(r8) :: ttmp - ! dummies for conservation check - real(r8) :: ratio - real(r8) :: tmpfrz - ! dummies for in-cloud variables - real(r8) :: dumc(mgncol,nlev) ! qc - real(r8) :: dumnc(mgncol,nlev) ! nc - real(r8) :: dumi(mgncol,nlev) ! qi - real(r8) :: dumni(mgncol,nlev) ! ni - real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio - real(r8) :: dumnr(mgncol,nlev) ! rain number concentration - real(r8) :: dums(mgncol,nlev) ! snow mixing ratio - real(r8) :: dumns(mgncol,nlev) ! snow number concentration -!++ag - real(r8) :: dumg(mgncol,nlev) ! graupel mixing ratio - real(r8) :: dumng(mgncol,nlev) ! graupel number concentration -!--ag - ! Array dummy variable -! real(r8) :: dum_2D(mgncol,nlev) - real(r8) :: pdel_inv(mgncol,nlev) - real(r8) :: ts_au_loc(mgncol) - - ! loop array variables - ! "i" and "k" are column/level iterators for internal (MG) variables - ! "n" is used for other looping (currently just sedimentation) - integer i, k, n - - ! number of sub-steps for loops over "n" (for sedimentation) - integer nstep, mdust, nlb, nstep_def - - ! Varaibles to scale fall velocity between small and regular ice regimes. -! real(r8) :: irad, ifrac, tsfac - real(r8) :: irad, ifrac -! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. -! logical, parameter :: do_ice_gmao=.false., do_liq_liu=.true. -! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. -! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & -! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) -! ts_au_min=180.0 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - - ! Process inputs - - !> - Assign variable deltat to deltatin - deltat = deltatin - oneodt = one / deltat -! nstep_def = max(1, nint(deltat/20)) - nstep_def = max(1, nint(deltat/5)) -! tsfac = log(ts_au/ts_au_min) * qiinv - - !> - Copies of input concentrations that may be changed internally. - do k=1,nlev - do i=1,mgncol - qc(i,k) = qcn(i,k) - nc(i,k) = ncn(i,k) - qi(i,k) = qin(i,k) - ni(i,k) = nin(i,k) - qr(i,k) = qrn(i,k) - nr(i,k) = nrn(i,k) - qs(i,k) = qsn(i,k) - ns(i,k) = nsn(i,k) -!++ag - qg(i,k) = qgr(i,k) - ng(i,k) = ngr(i,k) - enddo - enddo - - ! cldn: used to set cldm, unused for subcolumns - ! liqcldf: used to set lcldm, unused for subcolumns - ! icecldf: used to set icldm, unused for subcolumns -!> - Calculation liquid/ice cloud fraction - if (microp_uniform) then - ! subcolumns, set cloud fraction variables to one - ! if cloud water or ice is present, if not present - ! set to mincld (mincld used instead of zero, to prevent - ! possible division by zero errors). - - do k=1,nlev - do i=1,mgncol - - if (qc(i,k) >= qsmall) then - lcldm(i,k) = one - else - lcldm(i,k) = mincld - endif - - if (qi(i,k) >= qsmall) then - icldm(i,k) = one - else - icldm(i,k) = mincld - endif - - cldm(i,k) = max(icldm(i,k), lcldm(i,k)) -! qsfm(i,k) = one - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - - else ! get cloud fraction, check for minimum - do k=1,nlev - do i=1,mgncol - cldm(i,k) = max(cldn(i,k), mincld) - lcldm(i,k) = max(liqcldf(i,k), mincld) - icldm(i,k) = max(icecldf(i,k), mincld) - qsfm(i,k) = qsatfac(i,k) - enddo - enddo - end if - -! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' lcldm=',lcldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icecldf=',icecldf(1,nlev-20:nlev) -! if (lprnt) write(0,*)' icldm=',icldm(1,nlev-20:nlev) -! if (lprnt) write(0,*)' qsfm=',qsfm(1,nlev-20:nlev) - - !> - Initialize local variables - - ! local physical properties - -! write(0,*)' in mg2 T=',t(1,:) -! write(0,*)' in mg2 P=',p(1,:),' r=',r - do k=1,nlev - do i=1,mgncol -! rho(i,k) = p(i,k) / (r*t(i,k)*(one+fv*q(i,k))) - rho(i,k) = p(i,k) / (r*t(i,k)) - rhoinv(i,k) = one / rho(i,k) - dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k) - mu(i,k) = 1.496E-6_r8 * t(i,k)*sqrt(t(i,k)) / (t(i,k) + 120._r8) - sc(i,k) = mu(i,k) / (rho(i,k)*dv(i,k)) - - ! air density adjustment for fallspeed parameters - ! includes air density correction factor to the - ! power of 0.54 following Heymsfield and Bansemer 2007 - - rhof(i,k) = (rhosu*rhoinv(i,k))**0.54_r8 - - arn(i,k) = ar * rhof(i,k) - asn(i,k) = as * rhof(i,k) -!++ag if do hail then agn = ah *rhof else ag*rhof - agn(i,k) = agtmp * rhof(i,k) - acn(i,k) = g*rhow/(18._r8*mu(i,k)) - tx1 = (rhosu*rhoinv(i,k))**0.35_r8 - ain(i,k) = ai * tx1 - ajn(i,k) = aj * tx1 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Get humidity and saturation vapor pressures - -! do k=1,nlev -! do i=1,mgncol -! relvar(i,k) = relvar_i - accre_enhan(i,k) = accre_enhan_i -! call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) - esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) - qvl(i,k) = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) - - - ! make sure when above freezing that esi=esl, not active yet - if (t(i,k) >= tmelt) then - esi(i,k) = esl(i,k) - qvi(i,k) = qvl(i,k) - else -! call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) - esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) - qvi(i,k) = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) - end if - - ! Scale the water saturation values to reflect subgrid scale - ! ice cloud fraction, where ice clouds begin forming at a - ! gridbox average relative humidity of rhmini (not 1). - ! - ! NOTE: For subcolumns and other non-subgrid clouds, qsfm will be 1. - qvi(i,k) = qsfm(i,k) * qvi(i,k) -! esi(i,k) = qsfm(i,k) * esi(i,k) - qvl(i,k) = qsfm(i,k) * qvl(i,k) -! esl(i,k) = qsfm(i,k) * esl(i,k) - - relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) - end do - end do - - !=============================================== - - ! set mtime here to avoid answer-changing - mtime = deltat - - !> - initialize microphysics output - do k=1,nlev - do i=1,mgncol - qcsevap(i,k) = zero - qisevap(i,k) = zero - qvres(i,k) = zero - cmeitot(i,k) = zero - vtrmc(i,k) = zero - vtrmi(i,k) = zero - qcsedten(i,k) = zero - qisedten(i,k) = zero - qrsedten(i,k) = zero - qssedten(i,k) = zero -!++ag - qgsedten(i,k) = zero -!--ag - - - pratot(i,k) = zero - prctot(i,k) = zero - mnuccctot(i,k) = zero - mnuccttot(i,k) = zero - msacwitot(i,k) = zero - psacwstot(i,k) = zero - bergstot(i,k) = zero - bergtot(i,k) = zero - melttot(i,k) = zero - homotot(i,k) = zero - qcrestot(i,k) = zero - prcitot(i,k) = zero - praitot(i,k) = zero - qirestot(i,k) = zero - mnuccrtot(i,k) = zero -!++ag - mnuccritot(i,k) = zero -!--ag - - pracstot(i,k) = zero - meltsdttot(i,k) = zero - frzrdttot(i,k) = zero - mnuccdtot(i,k) = zero - -!++ag - psacrtot(i,k) = zero - pracgtot(i,k) = zero - psacwgtot(i,k) = zero - pgsacwtot(i,k) = zero - pgracstot(i,k) = zero - prdgtot(i,k) = zero -! eprdgtot(i,k) = zero - qmultgtot(i,k) = zero - qmultrgtot(i,k) = zero - npracgtot(i,k) = zero - nscngtot(i,k) = zero - ngracstot(i,k) = zero - nmultgtot(i,k) = zero - nmultrgtot(i,k) = zero - npsacwgtot(i,k) = zero -!need to zero these out to be totally switchable (for conservation) - psacr(i,k) = zero - pracg(i,k) = zero - psacwg(i,k) = zero - pgsacw(i,k) = zero - pgracs(i,k) = zero - - prdg(i,k) = zero -! eprdg(i,k) = zero - qmultg(i,k) = zero - qmultrg(i,k) = zero - npracg(i,k) = zero - nscng(i,k) = zero - ngracs(i,k) = zero - nmultg(i,k) = zero - nmultrg(i,k) = zero - npsacwg(i,k) = zero -!--ag - rflx(i,k+1) = zero - sflx(i,k+1) = zero - lflx(i,k+1) = zero - iflx(i,k+1) = zero -!++ag - gflx(i,k+1) = zero -!--ag - - !> - initialize precip output - - qrout(i,k) = zero - qsout(i,k) = zero - nrout(i,k) = zero - nsout(i,k) = zero -!++ag - qgout(i,k) = zero - ngout(i,k) = zero - dgout(i,k) = zero -!--ag - - ! for refl calc - rainrt(i,k) = zero - - !> - initialize rain size - rercld(i,k) = zero - - qcsinksum_rate1ord(i,k) = zero - - !> - initialize variables for trop_mozart - nevapr(i,k) = zero - prer_evap(i,k) = zero - evapsnow(i,k) = zero - am_evp_st(i,k) = zero - prain(i,k) = zero - prodsnow(i,k) = zero - cmeout(i,k) = zero - - precip_frac(i,k) = mincld - - lamc(i,k) = zero - - !> - initialize microphysical tendencies - - tlat(i,k) = zero - qvlat(i,k) = zero - qctend(i,k) = zero - qitend(i,k) = zero - qstend(i,k) = zero - qrtend(i,k) = zero - nctend(i,k) = zero - nitend(i,k) = zero - nrtend(i,k) = zero - nstend(i,k) = zero -!++ag - qgtend(i,k) = zero - ngtend(i,k) = zero -!--ag - - !> - initialize in-cloud and in-precip quantities to zero - qcic(i,k) = zero - qiic(i,k) = zero - qsic(i,k) = zero - qric(i,k) = zero -!++ag - qgic(i,k) = zero -!--ag - - - ncic(i,k) = zero - niic(i,k) = zero - nsic(i,k) = zero - nric(i,k) = zero -!++ag - ngic(i,k) = zero -!--ag - !> - initialize precip fallspeeds to zero - ums(i,k) = zero - uns(i,k) = zero - umr(i,k) = zero - unr(i,k) = zero -!++ag - umg(i,k) = zero - ung(i,k) = zero -!--ag - - !> - initialize limiter for output - qcrat(i,k) = one - - ! Many outputs have to be initialized here at the top to work around - ! ifort problems, even if they are always overwritten later. - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - effi(i,k) = 25._r8 - sadice(i,k) = zero - sadsnow(i,k) = zero - deffi(i,k) = 50._r8 - - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout(i,k) = zero - dsout2(i,k) = zero -!++ag - qgout2(i,k) = zero - ngout2(i,k) = zero - freqg(i,k) = zero - dgout2(i,k) = zero -!--ag - - freqr(i,k) = zero - freqs(i,k) = zero - - reff_rain(i,k) = zero - reff_snow(i,k) = zero -!++ag - reff_grau(i,k) = zero - lamg(i,k) = zero - n0g(i,k) = zero -!--ag - - refl(i,k) = -9999._r8 - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - csrfl(i,k) = zero - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - - ncal(i,k) = zero - ncai(i,k) = zero - - nfice(i,k) = zero - npccn(i,k) = zero - enddo - enddo -!> - initialize ccn activated number tendency (\p npccn) - if (iccn == 1) then - do k=1,nlev - do i=1,mgncol - npccn(i,k) = npccnin(i,k) - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) - enddo - enddo - endif - - !> - initialize precip at surface - - do i=1,mgncol - prect(i) = zero - preci(i) = zero - enddo - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! droplet activation - ! get provisional droplet number after activation. This is used for - ! all microphysical process calculations, for consistency with update of - ! droplet mass before microphysics - - ! calculate potential for droplet activation if cloud water is present - ! tendency from activation (npccn) is read in from companion routine - - ! output activated liquid and ice (convert from #/kg -> #/m3) - !-------------------------------------------------- -! where (qc >= qsmall .and. lcldm > mincld) -! where (qc >= qsmall) -! npccn = max((npccnin*lcldm-nc)*oneodt, zero) -! nc = max(nc + npccn*deltat, zero) -! ncal = nc*rho/lcldm ! sghan minimum in #/cm3 -! elsewhere -! ncal = zero -! end where - -! if (lprnt) write(0,*)' nc1=',nc(1,:) - do k=1,nlev - do i=1,mgncol - if (qc(i,k) > qsmall .and. lcldm(i,k) >= mincld) then - npccn(i,k) = max((npccnin(i,k)*lcldm(i,k)-nc(i,k))*oneodt, zero) - nc(i,k) = max(nc(i,k) + npccn(i,k)*deltat, zero) - ncal(i,k) = nc(i,k) * rho(i,k) / lcldm(i,k) - else - ncal(i,k) = 0.0 - endif - enddo - enddo - - if (iccn == 1) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 -! ncai(i,k) = min(ncai(i,k), 208.9e3_r8) - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = (ncai(i,k)*rhoinv(i,k) + naai(i,k)) * half - ncai(i,k) = naai(i,k)*rho(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - elseif (iccn == 2) then - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = naai(i,k)*rho(i,k) - ncai(i,k) = min(ncai(i,k), 710.0e3_r8) - naai(i,k) = ncai(i,k)*rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - else - do k=1,nlev - do i=1,mgncol - if (t(i,k) < icenuct) then - ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 - ncai(i,k) = min(ncai(i,k), 355.0e3_r8) - naai(i,k) = ncai(i,k)*rhoinv(i,k) - else - naai(i,k) = zero - ncai(i,k) = zero - endif - enddo - enddo - - endif - - - !=============================================== - - ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% - ! - ! NOTE: If using gridbox average values, condensation will not occur until rh=1, - ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid - ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus - ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. - - !------------------------------------------------------- - - if (do_cldice) then - where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8) -! where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8 & -! .and. icldm > mincld ) - - !if NAAI > 0. then set numice = naai (as before) - !note: this is gridbox averaged - nnuccd = (naai-ni/icldm)/mtime*icldm - nnuccd = max(nnuccd, zero) - nimax = naai*icldm - - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - - mnuccd = nnuccd * mi0 - - elsewhere - nnuccd = zero - nimax = zero - mnuccd = zero - end where - - end if - - - !============================================================================= - do k=1,nlev - - do i=1,mgncol - - ! calculate instantaneous precip processes (melting and homogeneous freezing) - - ! melting of snow at +2 C - - if (t(i,k) > snowmelt) then - if (qs(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * qs(i,k) - if (t(i,k)+dum < snowmelt) then - dum = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) - else - dum = one - end if - - minstsm(i,k) = dum*qs(i,k) - ninstsm(i,k) = dum*ns(i,k) - - dum1 = - minstsm(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - meltsdttot(i,k) = meltsdttot(i,k) + dum1 - -! if (lprnt .and. k >=40) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& -! ' minstsm=',minstsm(i,k),' qs=',qs(i,k),' xlf=',xlf,' oneodt=',oneodt, & -! ' snowmelt=',snowmelt,' t=',t(i,k),' dum=',dum,' k=',k - - qs(i,k) = max(qs(i,k) - minstsm(i,k), zero) - ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) - qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) - nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) - end if - end if - - end do - end do -! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qg1=',qg(1,:) - -!++ag - - if (do_graupel .or. do_hail) then -! melting of graupel at +2 C - - do k=1,nlev - do i=1,mgncol - - if (t(i,k) > snowmelt) then - if (qg(i,k) > zero) then - -! make sure melting graupel doesn't reduce temperature below threshold - dum = -(xlf/cpp) * qg(i,k) - if (t(i,k)+dum < snowmelt) then - dum = max(zero, min(one, (cpp/xlf)*(t(i,k)-snowmelt)/qg(i,k))) - else - dum = one - end if - - minstgm(i,k) = dum*qg(i,k) - ninstgm(i,k) = dum*ng(i,k) - - dum1 = - minstgm(i,k) * (xlf*oneodt) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - -! if (lprnt .and. k >=40) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& -! ' minstgm=',minstgm(i,k),' qg=',qg(i,k),' xlf=',xlf,' oneodt=',oneodt, & -! ' snowmelt=',snowmelt,' t=',t(i,k),' k=',k,' cpp=',cpp - - qg(i,k) = max(qg(i,k) - minstgm(i,k), zero) - ng(i,k) = max(ng(i,k) - ninstgm(i,k), zero) - qr(i,k) = max(qr(i,k) + minstgm(i,k), zero) - nr(i,k) = max(nr(i,k) + ninstgm(i,k), zero) - end if - end if - - end do - end do - endif - -! if (lprnt) write(0,*)' tlat1g=',tlat(1,:)*deltat -!--ag - - do k=1,nlev - do i=1,mgncol - ! freezing of rain at -5 C - - if (t(i,k) < rainfrze) then - - if (qr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * qr(i,k) - if (t(i,k)+dum > rainfrze) then - dum = -(t(i,k)-rainfrze) * (cpp/xlf) - dum = min(one, max(zero, dum/qr(i,k))) - else - dum = one - end if - - minstrf(i,k) = dum*qr(i,k) - ninstrf(i,k) = dum*nr(i,k) - - ! heating tendency - dum1 = minstrf(i,k) * (xlf*oneodt) - tlat(i,k) = tlat(i,k) + dum1 - frzrdttot(i,k) = frzrdttot(i,k) + dum1 - - qr(i,k) = max(qr(i,k) - minstrf(i,k), zero) - nr(i,k) = max(nr(i,k) - ninstrf(i,k), zero) - -!++ag -! freeze rain to graupel not snow. - if(do_hail .or. do_graupel) then - qg(i,k) = max(qg(i,k) + minstrf(i,k), zero) - ng(i,k) = max(ng(i,k) + ninstrf(i,k), zero) - else - qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) - ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) - end if -!--ag - - end if - end if - end do - end do - -! if (lprnt) then -! write(0,*)' tlat2=',tlat(1,:)*deltat -! write(0,*)' lcldm=',lcldm(1,:) -! write(0,*)' qc=',qc(1,:) -! write(0,*)' nc=',nc(1,:) -! write(0,*)' qg2=',qg(1,:) -! endif - - do k=1,nlev - do i=1,mgncol - ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations - !------------------------------------------------------- - ! for microphysical process calculations - ! units are kg/kg for mixing ratio, 1/kg for number conc - -! if (qc(i,k) >= qsmall .and. lcldm(i,k) > mincld) then - if (qc(i,k) >= qsmall) then - ! limit in-cloud values to 0.005 kg/kg - dum = one / lcldm(i,k) -! qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qcic(i,k) = min(qc(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - ncic(i,k) = max(nc(i,k)*dum, zero) - - ! specify droplet concentration - if (nccons) then - ncic(i,k) = ncnst * rhoinv(i,k) - end if - else - qcic(i,k) = zero - ncic(i,k) = zero - end if - -! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then - if (qi(i,k) >= qsmall) then - dum = one / icldm(i,k) -! qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) ! limit in-cloud values to 0.005 kg/kg - qiic(i,k) = min(qi(i,k)*dum, 0.05_r8) ! limit in-cloud values to 0.05 kg/kg - niic(i,k) = max(ni(i,k)*dum, zero) - - ! switch for specification of cloud ice number - if (nicons) then - niic(i,k) = ninst * rhoinv(i,k) - end if - else - qiic(i,k) = zero - niic(i,k) = zero - end if - - end do - end do - - !======================================================================== - - ! for sub-columns cldm has already been set to 1 if cloud - ! water or ice is present, so precip_frac will be correctly set below - ! and nothing extra needs to be done here - - precip_frac = cldm - - micro_vert_loop: do k=1,nlev - - if (trim(micro_mg_precip_frac_method) == 'in_cloud') then - - if (k /= 1) then - where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) - precip_frac(:,k) = precip_frac(:,k-1) - end where - endif - - else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then - -!++ag add graupel to precip frac? - ! calculate precip fraction based on maximum overlap assumption - - ! if rain or snow mix ratios are smaller than threshold, - ! then leave precip_frac as cloud fraction at current level - if (k /= 1) then -!++ag -! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) -!--ag - where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) - precip_frac(:,k) = max(precip_frac(:,k-1), precip_frac(:,k)) - end where - end if - - endif - - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get size distribution parameters based on in-cloud cloud water - ! these calculations also ensure consistency between number and mixing ratio - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! cloud liquid - !------------------------------------------- - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' qcic=',qcic(1,k),' ncic=',ncic(1,k),' rho=',rho(1,k),' k=',k -! endif - call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' k=',k -! endif - - - !======================================================================== - ! autoconversion of cloud liquid water to rain - ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc - ! minimum qc of 1 x 10^-8 prevents floating point error - - if (.not. do_sb_physics) then - call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & - ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) - endif - - ! assign qric based on prognostic qr, using assumed precip fraction - ! note: this could be moved above for consistency with qcic and qiic calculations - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg - qric(i,k) = min(qr(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - nric(i,k) = nr(i,k) * dum - - - ! add autoconversion to precip from above to get provisional rain mixing ratio - ! and number concentration (qric and nric) - - if(qric(i,k) < qsmall) then - qric(i,k) = zero - nric(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nric(i,k) = max(nric(i,k),zero) - enddo - ! Get size distribution parameters for cloud ice - - call size_dist_param_ice(mg_ice_props, qiic(:,k), niic(:,k), & - lami(:,k), mgncol, n0=n0i(:,k)) - - ! Alternative autoconversion - if (do_sb_physics) then - if (do_liq_liu) then - call liu_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k),mgncol) - else - call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) - endif - endif - - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - if (do_cldice) then - do i=1,mgncol - if (qiic(i,k) >= qimax) then -! if (qi(i,k) >= qimax) then - ts_au_loc(i) = ts_au_min - elseif (qiic(i,k) <= qimin) then -! elseif (qi(i,k) <= qimin) then - ts_au_loc(i) = ts_au - else -! ts_au_loc(i) = (ts_au*(qimax-qi(i,k)) + ts_au_min*(qi(i,k)-qimin)) * qiinv - ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv -! ts_au_loc(i) = ts_au * exp(-tsfac*(qiic(i,k)-qimin)) - endif -! if (ts_au_loc(i) > ts_au_min) ts_au_loc(i) = ts_au_loc(i)*min(five,sqrt(p(i,nlev)/p(i,k))) - enddo -! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qiic=',qiic(1,k),& -! if (lprnt) write(0,*)' ts_au_loc=',ts_au_loc(1),' k=',k, ' qi=',qi(1,k),& -! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' qimin=',qimin,' qimax=',qimax -! ' ts_au=',ts_au,' ts_au_min=',ts_au_min,' tsfac=',tsfac,' qimin=',qimin,' qimax=',qimax - - if(do_ice_gmao) then - call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & - n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - else - call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & - dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) - end if - !else - ! Add in the particles that we have already converted to snow, and - ! don't do any further autoconversion of ice. - !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) - !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) - end if - - ! note, currently we don't have this - ! inside the do_cldice block, should be changed later - ! assign qsic based on prognostic qs, using assumed precip fraction - do i=1,mgncol - if (precip_frac(i,k) > mincld) then - dum = one / precip_frac(i,k) - else - dum = zero - endif -! qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg - qsic(i,k) = min(qs(i,k)*dum, 0.05_r8) ! limit in-precip mixing ratios to 50 g/kg - nsic(i,k) = ns(i,k) * dum - - ! if precip mix ratio is zero so should number concentration - - if(qsic(i,k) < qsmall) then - qsic(i,k) = zero - nsic(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - nsic(i,k) = max(nsic(i,k), zero) - -!++ also do this for graupel, which is assumed to be 'precip_frac' - qgic(i,k) = min(qg(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg) - ngic(i,k) = ng(i,k) * dum - - ! if precip mix ratio is zero so should number concentration - if (qgic(i,k) < qsmall) then - qgic(i,k) = zero - ngic(i,k) = zero - endif - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - - ngic(i,k) = max(ngic(i,k), zero) -!--ag - enddo - - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & - lamr(:,k), mgncol, n0=n0r(:,k)) - - do i=1,mgncol - if (lamr(i,k) >= qsmall) then - dum = arn(i,k) / lamr(i,k)**br - dum1 = 9.1_r8*rhof(i,k) - - ! provisional rain number and mass weighted mean fallspeed (m/s) - - umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) - unr(i,k) = min(dum1, dum*gamma_br_plus1) - else - - umr(i,k) = zero - unr(i,k) = zero - endif - enddo - - !...................................................................... - ! snow - - call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & - lams(:,k), mgncol, n0=n0s(:,k)) - - do i=1,mgncol - if (lams(i,k) >= qsmall) then - - ! provisional snow number and mass weighted mean fallspeed (m/s) - - dum = asn(i,k) / lams(i,k)**bs - dum1 = 1.2_r8*rhof(i,k) - ums(i,k) = min(dum1, dum*gamma_bs_plus4*oneo6) - uns(i,k) = min(dum1, dum*gamma_bs_plus1) - - else - ums(i,k) = zero - uns(i,k) = zero - endif - enddo - - if (do_graupel .or. do_hail) then -!++ag -!use correct bg or bh (bgtmp=bg or bh) - !...................................................................... - ! graupel/hail - -!++AG SET rhog here and for mg_graupel_props? -! For now: rhog is constant. Set to same in micro_mg_utils.F90 -! Ideally: find a method to set once. (Hail = 400, Graupel = 500 from M2005) - -!mg,snow_props or mg_graupel props? - - call size_dist_param_basic(mg_graupel_props, qgic(:,k), ngic(:,k), & - lamg(:,k), mgncol, n0=n0g(:,k)) - - do i=1,mgncol - if (lamg(i,k) >= qsmall) then - - ! provisional graupel/hail number and mass weighted mean fallspeed (m/s) - - dum = agn(i,k) / lamg(i,k)**bgtmp - dum1 = 20._r8*rhof(i,k) - umg(i,k) = min(dum1, dum*gamma_bg_plus4*oneo6) - ung(i,k) = min(dum1, dum*gamma_bg_plus1) -! umg(i,k) = min(dum1, dum*gamma(four+bgtmp)*oneo6) -! ung(i,k) = min(dum1, dum*gamma(one+bgtmp)) - - else - umg(i,k) = zero - ung(i,k) = zero - endif - enddo -!--ag - endif - - if (do_cldice) then - if (.not. use_hetfrz_classnuc) then - - ! heterogeneous freezing of cloud water - !---------------------------------------------- - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' qcic=',qcic(1,k),' ncic=',ncic(1,k),' t=',t(1,k),' k=',k,& -! ' relvar=',relvar(1,k) -! endif - - call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & - qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) - -! if (lprnt .and. k>=60 .and. k<=65) then -! if (lprnt .and. k>=100) then -! if (lprnt) then -! write(0,*)' mnuccca=',mnuccc(1,k),' lcldm=',lcldm(1,k),' nnuccc=',nnuccc(1,k),' k=',k -! endif - - ! make sure number of droplets frozen does not exceed available ice nuclei concentration - ! this prevents 'runaway' droplet freezing - -! where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8 .and. lcldm(:,k) > mincld) - where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8) - where (nnuccc(:,k)*lcldm(:,k) > nnuccd(:,k)) - ! scale mixing ratio of droplet freezing with limit - mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) - nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) - end where - end where - -! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnuccc=',mnuccc(1,60:65) -! if (lprnt .and. k >= 100) write(0,*)' mnuccc=',mnuccc(1,k) -! if (lprnt) write(0,*)' mnuccc=',mnuccc(1,k) - - mdust = size(rndst,3) - call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & - nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & - relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) - -! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnucct=',mnucct(1,:) -! if (lprnt .and. k >= 100 ) write(0,*)' mnucct=',mnucct(1,k) -! if (lprnt) write(0,*)' mnucct=',mnucct(1,k) - - mnudep(:,k) = zero - nnudep(:,k) = zero - - !else - - ! Mass of droplets frozen is the average droplet mass, except - ! with two limiters: concentration must be at least 1/cm^3, and - ! mass must be at least the minimum defined above. - !mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) - !mi0l = max(mi0l_min, mi0l) - - !where (qcic(:,k) >= qsmall) - !nnuccc(:,k) = frzimm(:,k)*1.0e6_r8*rhoinv(:,k) - !mnuccc(:,k) = nnuccc(:,k)*mi0l - - !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8*rhoinv(:,k) - !mnucct(:,k) = nnucct(:,k)*mi0l - - !nnudep(:,k) = frzdep(:,k)*1.0e6_r8*rhoinv(:,k) - !mnudep(:,k) = nnudep(:,k)*mi0 - !elsewhere - !nnuccc(:,k) = zero - !mnuccc(:,k) = zero - - !nnucct(:,k) = zero - !mnucct(:,k) = zero - - !nnudep(:,k) = zero - !mnudep(:,k) = zero - !end where - - end if - - else - do i=1,mgncol - mnuccc(i,k) = zero - nnuccc(i,k) = zero - mnucct(i,k) = zero - nnucct(i,k) = zero - mnudep(i,k) = zero - nnudep(i,k) = zero - enddo - end if - - call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & - nsagg(:,k), mgncol) - - call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & - qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & - psacws(:,k), npsacws(:,k), mgncol) - - if (do_cldice) then - call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) - else - nsacwi(:,k) = zero - msacwi(:,k) = zero - end if - - call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pracs(:,k), npracs(:,k), mgncol) - - call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & - mnuccr(:,k), nnuccr(:,k), mgncol) - - if (do_sb_physics) then - call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & - rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) - else - call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & - ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) - endif - - call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) - - if (do_cldice) then - call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & - qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) - else - prai(:,k) = zero - nprai(:,k) = zero - end if - -!++ag Moved below graupel conditional, now two different versions -! if (.not. (do_hail .or. do_graupel)) then -! call evaporate_sublimate_precip(t(:,k), rho(:,k), & -! dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & -! lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & -! qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & -! pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) -! endif -!--ag - - call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & - qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & - bergs(:,k), mgncol) -! if(lprnt) write(0,*)' bergs1=',bergs(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor -! if(lprnt) write(0,*)' t=',t(1,k),' rho=',rho(1,k),' dv=',dv(1,k),' mu=',mu(1,k),& -! 'qcic=',qcic(1,k),' qsic=',qsic(1,k),' qvl=',qvl(1,k),' qvi=',qvi(1,k), & -! ' mu=',mu(1,k),' sc=',sc(1,k),' asn=',asn(1,k),' lams=',lams(1,k),' n0s=',n0s(1,k),' ni=',ni(1,k) - - bergs(:,k) = bergs(:,k) * micro_mg_berg_eff_factor - - !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! - if (do_cldice) then - - call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & - icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & - berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) - -! if(lprnt) write(0,*)' t=',t(1,k),' k=',k,' q=',q(1,k),' qi=',qi(1,k),& -! ' ni=',ni(1,k),' icldm=',icldm(1,k),' rho=',rho(1,k),' dv=',dv(1,k),& -! ' qvl=',qvl(1,k),' qvi=',qvi(1,k),' berg=',berg(1,k),' vap_dep=',& -! vap_dep(1,k),' ice_sublim=',ice_sublim(1,k) -! if(lprnt) write(0,*)' berg1=',berg(1,k),' k=',k,' micro_mg_berg_eff_factor=',micro_mg_berg_eff_factor - do i=1,mgncol -! sublimation should not exceed available ice - ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) - berg(i,k) = berg(i,k) * micro_mg_berg_eff_factor - if (ice_sublim(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then - nsubi(i,k) = sublim_factor * ice_sublim(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) - else - nsubi(i,k) = zero - endif - - ! bergeron process should not reduce nc unless - ! all ql is removed (which is handled elsewhere) - !in fact, nothing in this entire file makes nsubc nonzero. - nsubc(i,k) = zero - end do - - end if !do_cldice - !---PMC 12/3/12 - -!++ag Process rate calls for graupel here. -! (Should this be in do_cldice loop?) -!=================================================================== - - if(do_hail .or. do_graupel) then - call graupel_collecting_snow(qsic(:,k),qric(:,k),umr(:,k),ums(:,k), & - rho(:,k),lamr(:,k),n0r(:,k),lams(:,k),n0s(:,k), psacr(:,k), mgncol) - - call graupel_collecting_cld_water(qgic(:,k),qcic(:,k),ncic(:,k),rho(:,k), & - n0g(:,k),lamg(:,k),bgtmp,agn(:,k), psacwg(:,k), npsacwg(:,k), mgncol) - - call graupel_riming_liquid_snow(psacws(:,k),qsic(:,k),qcic(:,k),nsic(:,k), & - rho(:,k),rhosn,rhogtmp,asn(:,k),lams(:,k),n0s(:,k),deltat, & - pgsacw(:,k),nscng(:,k),mgncol) - -! if(lprnt .and. k >=100) then -! if(lprnt) then -! write(0,*)' k=',k,' qric=',qric(1,k),' qgic=',qgic(1,k),' umg=',umg(1,k),' umr=',umr(1,k),& -! ' ung=',ung(1,k),' unr=',unr(1,k),' rho=',rho(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k),& -! ' n0g=',n0g(1,k),' lamg=',lamg(1,k),' pracg=',pracg(1,k) -! endif - call graupel_collecting_rain(qric(:,k),qgic(:,k),umg(:,k), & - umr(:,k),ung(:,k),unr(:,k),rho(:,k),n0r(:,k),lamr(:,k),n0g(:,k), & - lamg(:,k), pracg(:,k),npracg(:,k),mgncol) -! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg=',pracg(1,k),' npracg=',npracg(1,k) - -!AG note: Graupel rain riming snow changes -! pracs, npracs, (accretion of rain by snow) psacr (collection of snow by rain) - -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& -! ' qsic=',qsic(1,k),' qric=',qric(1,k),' nric=',nric(1,k),' nsic=',nsic(1,k), & -! ' n0s=',n0s(1,k),' lams=',lams(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k), & -! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) - - call graupel_rain_riming_snow(pracs(:,k),npracs(:,k),psacr(:,k),qsic(:,k), & - qric(:,k),nric(:,k),nsic(:,k),n0s(:,k),lams(:,k),n0r(:,k),lamr(:,k), & - deltat,pgracs(:,k),ngracs(:,k),mgncol) -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& -! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) - - call graupel_rime_splintering(t(:,k),qcic(:,k),qric(:,k),qgic(:,k), & - psacwg(:,k),pracg(:,k),qmultg(:,k),nmultg(:,k),qmultrg(:,k), & - nmultrg(:,k),mgncol) - -! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg2=',pracg(1,k) -! if (lprnt .and. abs(k-81) <5) & -! write(0,*)' k=',k,' pracg2=',pracg(1,k) - - call evaporate_sublimate_precip_graupel(t(:,k), rho(:,k), & - dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & - lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), agn(:,k), bgtmp, & - qcic(:,k), qiic(:,k), qric(:,k), qsic(:,k), qgic(:,k), & - lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), lamg(:,k), n0g(:,k), & - pre(:,k), prds(:,k), prdg(:,k), am_evp_st(:,k), mgncol) - -!!Not used: part of above -!! call graupel_sublimate_evap(t(:,k),q(:,k),qgic(:,k),rho(:,k),n0g(:,k), & -!! lamg(:,k),qvi(:,k),dv(:,k),mu(:,k),sc(:,k),bgtmp,agn(:,k), & -!! prdg(:,k),eprdg(:,k),mgncol) - -!Checks for Debugging - -! if (minval(qmultg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, qmultg < 0 : min=",minval(qmultg(:,k)) -! -! if (minval(qmultrg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, qmultrg < 0 : min=",minval(qmultrg(:,k)) -! -! if (minval(pgracs(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, pgracs < 0 : min=",minval(pgracs(:,k)) -! -! if (minval(psacwg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, psacwg < 0 : min=",minval(psacwg(:,k)) -! -! if (minval(npsacwg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, npsacwg < 0 : min=",minval(npsacwg(:,k)) -! -! if (minval(pracg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, pracg < 0 : min=",minval(pracg(:,k)) -! -! if (maxval(prdg(:,k)).gt.0._r8) & -! write(iulog,*) "OOPS, prdg > 0 : max=",maxval(prdg(:,k)) -! -! if (minval(nmultg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nmultg < 0 : min=",minval(nmultg(:,k)) -! -! if (minval(nmultrg(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nmultrg < 0 : min=",minval(nmultrg(:,k)) -! -! if (minval(ngracs(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, ngracs < 0 : min=",minval(ngracs(:,k)) -! -! if (minval(psacr(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, psacr < 0 : min=",minval(psacr(:,k)) -! -! if (minval(nscng(:,k)).lt.0._r8) & -! write(iulog,*) "OOPS, nscng < 0 : min=",minval(nscng(:,k)) - - else -! Routine without Graupel (original) - call evaporate_sublimate_precip(t(:,k), rho(:,k), & - dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & - lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & - qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & - pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) - - - end if ! end do_graupel/hail loop -!--ag - - do i=1,mgncol - - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - !=================================================================== - - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - - ! conservation of qc - !------------------------------------------------------------------- - -!++ag Add graupel tendencies for qc to equation ON -! dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & -! psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat - dum = ( (prc(i,k) + pra(i,k) + mnuccc(i,k) + mnucct(i,k) + msacwi(i,k) & - + psacws(i,k) + bergs(i,k) + qmultg(i,k) + psacwg(i,k) + pgsacw(i,k))*lcldm(i,k) & - + berg(i,k) ) * deltat -!--ag - - if (dum > qc(i,k) .and. abs(dum) > qsmall) then -!++ag -! ratio = qc(i,k)/deltat/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & -! msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm - - ratio = qc(i,k) / dum * omsm - - qmultg(i,k) = ratio * qmultg(i,k) - psacwg(i,k) = ratio * psacwg(i,k) - pgsacw(i,k) = ratio * pgsacw(i,k) -!--ag - prc(i,k) = ratio * prc(i,k) - pra(i,k) = ratio * pra(i,k) - mnuccc(i,k) = ratio * mnuccc(i,k) - mnucct(i,k) = ratio * mnucct(i,k) - msacwi(i,k) = ratio * msacwi(i,k) - psacws(i,k) = ratio * psacws(i,k) - bergs(i,k) = ratio * bergs(i,k) - berg(i,k) = ratio * berg(i,k) - qcrat(i,k) = ratio - else - qcrat(i,k) = one - end if - -! if(lprnt) write(0,*)' bergs2=',bergs(1,k),' k=',k,' ratio=',ratio - - !PMC 12/3/12: ratio is also frac of step w/ liquid. - !thus we apply berg for "ratio" of timestep and vapor - !deposition for the remaining frac of the timestep. - if (qc(i,k) >= qsmall) then - vap_dep(i,k) = vap_dep(i,k) * (one-qcrat(i,k)) - end if - - end do - - do i=1,mgncol - - !================================================================= - ! apply limiter to ensure that ice/snow sublimation and rain evap - ! don't push conditions into supersaturation, and ice deposition/nucleation don't - ! push conditions into sub-saturation - ! note this is done after qc conservation since we don't know how large - ! vap_dep is before then - ! estimates are only approximate since other process terms haven't been limited - ! for conservation yet - - ! first limit ice deposition/nucleation vap_dep + mnuccd - - dum1 = vap_dep(i,k) + mnuccd(i,k) - if (dum1 > 1.e-20_r8) then - dum = (q(i,k)-qvi(i,k))/(one + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)*t(i,k)))*oneodt - dum = max(dum, zero) - if (dum1 > dum) then - ! Allocate the limited "dum" tendency to mnuccd and vap_dep - ! processes. Don't divide by cloud fraction; these are grid- - ! mean rates. - dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) - mnuccd(i,k) = dum*dum1 - vap_dep(i,k) = dum - mnuccd(i,k) - end if - end if - - end do - - do i=1,mgncol - - !=================================================================== - ! conservation of nc - !------------------------------------------------------------------- -!++ag NEW ONE ON -! dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & -! npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat - dum = (nprc1(i,k) + npra(i,k) + nnuccc(i,k) + nnucct(i,k) & - + npsacws(i,k) - nsubc(i,k) + npsacwg(i,k))*lcldm(i,k)*deltat -!--ag - - if (dum > nc(i,k) .and. abs(dum) > qsmall) then - ratio = nc(i,k) / dum * omsm -!++ag - npsacwg(i,k) = ratio * npsacwg(i,k) -!--ag - - nprc1(i,k) = ratio * nprc1(i,k) - npra(i,k) = ratio * npra(i,k) - nnuccc(i,k) = ratio * nnuccc(i,k) - nnucct(i,k) = ratio * nnucct(i,k) - npsacws(i,k) = ratio * npsacws(i,k) - nsubc(i,k) = ratio * nsubc(i,k) - end if - - mnuccri(i,k) = zero - nnuccri(i,k) = zero - - if (do_cldice) then - - ! freezing of rain to produce ice if mean rain size is smaller than Dcs - if (lamr(i,k) > qsmall .and. one/lamr(i,k) < Dcs) then - mnuccri(i,k) = mnuccr(i,k) - nnuccri(i,k) = nnuccr(i,k) - mnuccr(i,k) = zero - nnuccr(i,k) = zero - end if - end if - - end do - - do i=1,mgncol - - ! conservation of rain mixing ratio - !------------------------------------------------------------------- -!++ag Implemented change for graupel - dum1 = - pre(i,k) + pracs(i,k) + mnuccr(i,k) + mnuccri(i,k) & - + qmultrg(i,k) + pracg(i,k) + pgracs(i,k) - dum3 = dum1 * precip_frac(i,k) - dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) - dum = (dum3 - dum2) * deltat -!--ag - - ! note that qrtend is included below because of instantaneous freezing/melt - if (dum > qr(i,k) .and. dum1 >= qsmall .and. abs(dum3) > qsmall) then - ratio = (qr(i,k)*oneodt + dum2) / dum3 * omsm -!++ag - qmultrg(i,k) = ratio * qmultrg(i,k) - pracg(i,k) = ratio * pracg(i,k) - pgracs(i,k) = ratio * pgracs(i,k) -!--ag - pre(i,k) = ratio * pre(i,k) - pracs(i,k) = ratio * pracs(i,k) - mnuccr(i,k) = ratio * mnuccr(i,k) - mnuccri(i,k) = ratio * mnuccri(i,k) - end if - - end do - - do i=1,mgncol - - ! conservation of rain number - !------------------------------------------------------------------- - - ! Add evaporation of rain number. - if (pre(i,k) < zero) then - dum = max(-one, pre(i,k)*deltat/qr(i,k)) - nsubr(i,k) = dum*nr(i,k) * oneodt - else - nsubr(i,k) = zero - end if - - end do - - do i=1,mgncol - -!++ag IMplemented change for graupel -! dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) -! nprc(i,k)*lcldm(i,k))*deltat - - dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k) & - +npracg(i,k)+ngracs(i,k))*precip_frac(i,k) - dum2 = nprc(i,k)*lcldm(i,k) - dum = (dum1 - dum2) * deltat -!--ag - - if (dum > nr(i,k) .and. abs(dum1) > qsmall) then - ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm - -!++ag - npracg(i,k) = ratio * npracg(i,k) - ngracs(i,k) = ratio * ngracs(i,k) -!--ag - nragg(i,k) = ratio * nragg(i,k) - npracs(i,k) = ratio * npracs(i,k) - nnuccr(i,k) = ratio * nnuccr(i,k) - nsubr(i,k) = ratio * nsubr(i,k) - nnuccri(i,k) = ratio * nnuccri(i,k) - end if - - end do - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of qi - !------------------------------------------------------------------- - -!++ag - - dum1 = (prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k) -! dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & -! + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k) & -! + mnuccri(i,k)*precip_frac(i,k) - dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & - + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k) & - + (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k) - dum = (dum1 - dum2) * deltat -!-ag - - if (dum > qi(i,k) .and. abs(dum1) > qsmall) then - ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm - -!++ag -! Only sink terms are limited. -! qmultg(i,k) = ratio * qmultg(i,k) -! qmultrg(i,k) = ratio * qmultrg(i,k) -!--ag - prci(i,k) = ratio * prci(i,k) - prai(i,k) = ratio * prai(i,k) - ice_sublim(i,k) = ratio * ice_sublim(i,k) - end if - - end do - - end if - - if (do_cldice) then - - do i=1,mgncol - - ! conservation of ni - !------------------------------------------------------------------- - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if -!++ag - dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) -! dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & -! + nnuccri(i,k)*precip_frac(i,k) - dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & - + (nmultrg(i,k)+nnuccri(i,k))*precip_frac(i,k) -!--ag - dum = (dum1 - dum2) * deltat - - if (dum > ni(i,k) .and. abs(dum1) > qsmall) then - ratio = (ni(i,k)*oneodt + dum2) / dum1 * omsm - - nprci(i,k) = ratio * nprci(i,k) - nprai(i,k) = ratio * nprai(i,k) - nsubi(i,k) = ratio * nsubi(i,k) - end if - - end do - - end if - - do i=1,mgncol - - ! conservation of snow mixing ratio - !------------------------------------------------------------------- -!++ag - if (do_hail .or. do_graupel) then -!NOTE: mnuccr is moved to graupel when active -!psacr is a positive value, but a loss for snow -!HM: psacr is positive in dum (two negatives) - - dum1 = (psacr(i,k) - prds(i,k)) * precip_frac(i,k) - dum2 = pracs(i,k)*precip_frac(i,k) & - + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - if (dum > qs(i,k) .and. psacr(i,k)-prds(i,k) >= qsmall) then - ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - psacr(i,k) = ratio * psacr(i,k) - prds(i,k) = ratio * prds(i,k) - endif - else - dum1 = - prds(i,k) * precip_frac(i,k) - dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then - ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - prds(i,k) = ratio * prds(i,k) - endif - endif - -!--ag -! dum1 = - prds(i,k) * precip_frac(i,k) -! dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & -! + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) - -! dum = (dum1 - dum2) * deltat - -! if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then -! ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm - -! prds(i,k) = ratio * prds(i,k) -! end if - - end do - - do i=1,mgncol - - ! conservation of snow number - !------------------------------------------------------------------- - ! calculate loss of number due to sublimation - ! for now neglect sublimation of ns - nsubs(i,k) = zero - - ratio = one -!++ag Watch sign of nscng and ngracs. What is sign of nnuccr? Negative? Should be a source here. - - if (do_hail .or. do_graupel) then -! dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) -! dum2 = nprci(i,k)*icldm(i,k) + nscng(i,k)*lcldm(i,k) -! dum = (dum1 - dum2) * deltat -! check here - this is slightly different from ag version - moorthi - - dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) & - - nscng(i,k)*lcldm(i,k) - dum2 = nprci(i,k)*icldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ns(i,k) .and. abs(dum1) > qsmall) then - ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm - nscng(i,k) = ratio * nscng(i,k) - ngracs(i,k) = ratio * ngracs(i,k) - end if - - else - dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) - dum2 = nnuccr(i,k)*precip_frac(i,k) + nprci(i,k)*icldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > ns(i,k) .and. abs(dum1) > qsmall) then - ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm - end if - endif - nsubs(i,k) = ratio * nsubs(i,k) - nsagg(i,k) = ratio * nsagg(i,k) - - end do - -!++ag Graupel Conservation Checks -!------------------------------------------------------------------- - if (do_hail .or. do_graupel) then -! conservation of graupel mass -!------------------------------------------------------------------- - do i=1,mgncol - - dum1 = -prdg(i,k) * precip_frac(i,k) - dum2 = (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) - dum = (dum1 - dum2) * deltat - - if (dum > qg(i,k) .and. abs(dum1) > qsmall) then - -! hm added -! note: prdg is always negative (like prds), so it needs to be subtracted in ratio - ratio = (qg(i,k)*oneodt + dum2) / dum1 * omsm - - prdg(i,k) = ratio * prdg(i,k) - - end if - - end do - -! conservation of graupel number: not needed, no sinks -!------------------------------------------------------------------- - end if -!--ag - - - do i=1,mgncol - - ! next limit ice and snow sublimation and rain evaporation - ! get estimate of q and t at end of time step - ! don't include other microphysical processes since they haven't - ! been limited via conservation checks yet - -!++ag need to add graupel sublimation/evap here too (prdg)? May not need eprdg? -!++ag - tx1 = pre(i,k) * precip_frac(i,k) - tx2 = prds(i,k) * precip_frac(i,k) - tx6 = prdg(i,k) * precip_frac(i,k) - tx5 = tx2 + tx6 - tx3 = tx1 + tx5 + ice_sublim(i,k) - - if (tx3 < -1.e-20_r8) then - - tx4 = tx5 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) - qtmp = q(i,k) - (tx1 + tx4) * deltat - ttmp = t(i,k) + (tx1*xxlv + tx4*xxls) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - ! call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn/(p(i,k)-omeps*esn) - - ! modify ice/precip evaporation rate if q > qsat - if (qtmp > qvn) then - - tx4 = one / tx3 - dum1 = tx1 * tx4 - dum2 = tx2 * tx4 -!++ag - dum3 = tx6 * tx4 -!--ag - ! recalculate q and t after vap_dep and mnuccd but without evap or sublim - tx5 = (vap_dep(i,k)+mnuccd(i,k)) * deltat - qtmp = q(i,k) - tx5 - ttmp = t(i,k) + tx5 * (xxls/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn / (p(i,k)-omeps*esn) - - dum = min(zero, (qtmp-qvn)/(one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp))) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - if (precip_frac(i,k) > mincld) then - tx4 = oneodt / precip_frac(i,k) - else - tx4 = zero - endif - pre(i,k) = dum*dum1*tx4 - - ! do separately using RHI for prds and ice_sublim - !call qsat_ice(ttmp, p(i,k), esn, qvn) - esn = min(fpvsi(ttmp), p(i,k)) - qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn / (p(i,k)-omeps*esn) - - - dum = min(zero, (qtmp-qvn)/(one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp))) - - ! modify rates if needed, divide by precip_frac to get local (in-precip) value - prds(i,k) = dum*dum2*tx4 -!++ag - prdg(i,k) = dum*dum3*tx4 -!--ag -!++ag - ! don't divide ice_sublim by cloud fraction since it is grid-averaged -! dum1 = one - dum1 - dum2 - dum1 = one - dum1 - dum2 - dum3 -!--ag - ice_sublim(i,k) = dum*dum1*oneodt - end if - end if - - end do - - ! Big "administration" loop enforces conservation, updates variables - ! that accumulate over substeps, and sets output variables. - - do i=1,mgncol - - ! get tendencies due to microphysical conversion processes - !========================================================== - ! note: tendencies are multiplied by appropriate cloud/precip - ! fraction to get grid-scale values - ! note: vap_dep is already grid-average values - - ! The net tendencies need to be added to rather than overwritten, - ! because they may have a value already set for instantaneous - ! melting/freezing. - -!++ag -! qvlat(i,k) = qvlat(i,k) - (pre(i,k)+prds(i,k))*precip_frac(i,k)-& -! vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) - - qvlat(i,k) = qvlat(i,k)-(pre(i,k)+prds(i,k))*precip_frac(i,k) & - -vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) & - -prdg(i,k)*precip_frac(i,k) - -! tlat(i,k) = tlat(i,k) + ((pre(i,k)*precip_frac(i,k)) & -! *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & -! ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & -! pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) - -! if (lprnt .and. k >= 60 .and. k <=65) & -! if (lprnt .and. k >= 100 ) & -! if (lprnt .and. abs(k-81) <5) & -! if (lprnt .and. k >= 60 ) & -! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& -! ' prds=',prds(i,k),' prdg=',prdg(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & -! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & -! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & -! ' psacwg=',psacwg(i,k),' qmultg=',qmultg(i,k),' pgsacw=',pgsacw(i,k),' mnuccr=',mnuccr(i,k), & -! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' pracg=',pracg(i,k),' pgracs=',pgracs(i,k), & -! ' qmultrg=',qmultrg(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls - - - tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & - ((prds(i,k)+prdg(i,k))*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+ & - mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & - ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+psacwg(i,k)+ & - qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ & - (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ & - berg(i,k))*xlf) - -! if (lprnt .and. k >= 100 ) write(0,*)' k=',k,' tlat=',tlat(i,k) -! if (lprnt) write(0,*)' k=',k,' tlat=',tlat(i,k) -! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) - -! qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & -! psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) - - qctend(i,k) = qctend(i,k) + & - (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k) - & - psacws(i,k)-bergs(i,k)-qmultg(i,k)-psacwg(i,k)-pgsacw(i,k))*lcldm(i,k)-berg(i,k) - - if (do_cldice) then -! qitend(i,k) = qitend(i,k) + & -! (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & -! prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & -! mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) - - qitend(i,k) = qitend(i,k)+ & - (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k)) * lcldm(i,k) & - + (-prci(i,k)-prai(i,k)) * icldm(i,k) & - + vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+mnuccd(i,k) & - + (mnuccri(i,k)+qmultrg(i,k)) * precip_frac(i,k) - - end if - -! qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & -! mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) - - qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & - mnuccr(i,k)-mnuccri(i,k)-qmultrg(i,k)-pracg(i,k)-pgracs(i,k))*precip_frac(i,k) - - -! qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & -! + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - - if (do_hail.or.do_graupel) then - qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & - + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) - - qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & - + (prds(i,k)+pracs(i,k)-psacr(i,k))*precip_frac(i,k) - - else - !necessary since mnuccr moved to graupel - qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & - + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - - end if -!--ag - - - cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! add output for cmei (accumulate) - cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) - - ! assign variables for trop_mozart, these are grid-average - !------------------------------------------------------------------- - ! evaporation/sublimation is stored here as positive term - -!++add evaporation/sublimation of graupel too? YES: After conservation checks. - -!++ag -!ADD GRAUPEL to evapsnow: prdg. (sign? same as prds: negative, so this is a positive number) -! evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) - evapsnow(i,k) = (-prds(i,k)-prdg(i,k)) * precip_frac(i,k) -!--ag - nevapr(i,k) = -pre(i,k) * precip_frac(i,k) - prer_evap(i,k) = -pre(i,k) * precip_frac(i,k) - - ! change to make sure prain is positive: do not remove snow from - ! prain used for wet deposition - -!++AG NEED TO MAKE CONSISTENT WITH BUDGETS - prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k) & - - (pracs(i,k)+mnuccr(i,k)+mnuccri(i,k))*precip_frac(i,k) - if (do_hail .or. do_graupel) then -! Subtract PSACR here or not? Ask Hugh - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & - pracs(i,k)*precip_frac(i,k) - else - prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & - (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) - end if - - ! following are used to calculate 1st order conversion rate of cloud water - ! to rain and snow (1/s), for later use in aerosol wet removal routine - ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc - ! used to calculate pra, prc, ... in this routine - ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } - ! (no cloud ice or bergeron terms) - -!++AG NEED TO MAKE CONSITANT: PGSACW, PSACWG (check budgets)? More sink terms? Check. No. Just loss to precip. -!Ask Hugh -! qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) - qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) -!--ag - ! Avoid zero/near-zero division. - qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) - - - ! microphysics output, note this is grid-averaged - pratot(i,k) = pra(i,k) * lcldm(i,k) - prctot(i,k) = prc(i,k) * lcldm(i,k) - mnuccctot(i,k) = mnuccc(i,k) * lcldm(i,k) - mnuccttot(i,k) = mnucct(i,k) * lcldm(i,k) - msacwitot(i,k) = msacwi(i,k) * lcldm(i,k) - psacwstot(i,k) = psacws(i,k) * lcldm(i,k) - bergstot(i,k) = bergs(i,k) * lcldm(i,k) - bergtot(i,k) = berg(i,k) - prcitot(i,k) = prci(i,k) * icldm(i,k) - praitot(i,k) = prai(i,k) * icldm(i,k) - mnuccdtot(i,k) = mnuccd(i,k) * icldm(i,k) - - pracstot(i,k) = pracs(i,k) * precip_frac(i,k) - mnuccrtot(i,k) = mnuccr(i,k) * precip_frac(i,k) -!++ag - mnuccritot(i,k) = mnuccri(i,k) * precip_frac(i,k) -!--ag - -!++ag Hail/Graupel tendencies for output - psacrtot(i,k) = psacr(i,k) * precip_frac(i,k) - pracgtot(i,k) = pracg(i,k) * precip_frac(i,k) - psacwgtot(i,k) = psacwg(i,k) * lcldm(i,k) - pgsacwtot(i,k) = pgsacw(i,k) * lcldm(i,k) - pgracstot(i,k) = pgracs(i,k) * precip_frac(i,k) - prdgtot(i,k) = prdg(i,k) * precip_frac(i,k) - qmultgtot(i,k) = qmultg(i,k) * lcldm(i,k) - qmultrgtot(i,k) = qmultrg(i,k) * precip_frac(i,k) - npracgtot(i,k) = npracg(i,k) * precip_frac(i,k) - nscngtot(i,k) = nscng(i,k) * lcldm(i,k) - ngracstot(i,k) = ngracs(i,k) * precip_frac(i,k) - nmultgtot(i,k) = nmultg(i,k) * lcldm(i,k) - nmultrgtot(i,k) = nmultrg(i,k) * precip_frac(i,k) - npsacwgtot(i,k) = npsacwg(i,k) * lcldm(i,k) -!--ag - -!++ag -! nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & -! - npra(i,k)-nprc1(i,k))*lcldm(i,k) - - nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & - -npra(i,k)-nprc1(i,k)-npsacwg(i,k))*lcldm(i,k) - - if (do_cldice) then - if (use_hetfrz_classnuc) then - tmpfrz = nnuccc(i,k) - else - tmpfrz = zero - end if -! nitend(i,k) = nitend(i,k) + nnuccd(i,k)+ & -! (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & -! nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) - - nitend(i,k) = nitend(i,k) + nnuccd(i,k) & - + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & - + (nsubi(i,k)-nprci(i,k)-nprai(i,k))*icldm(i,k) & - + (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k) - end if - - if(do_graupel.or.do_hail) then -! nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & -! + nprci(i,k)*icldm(i,k) - - nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)-ngracs(i,k))*precip_frac(i,k) & - + nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k) - - ngtend(i,k) = ngtend(i,k) + nscng(i,k)*lcldm(i,k) & - + (ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k) - - else - !necessary since mnuccr moved to graupel - nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & - + nprci(i,k)*icldm(i,k) - - end if - -! nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & -! - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) - - nrtend(i,k) = nrtend(i,k)+ nprc(i,k)*lcldm(i,k) & - + (nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & - -nnuccri(i,k)+nragg(i,k)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k) -!--ag - - ! make sure that ni at advanced time step does not exceed - ! maximum (existing N + source terms*dt), which is possible if mtime < deltat - ! note that currently mtime = deltat - !================================================================ - - if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then - nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) - end if - - end do - - ! End of "administration" loop - - end do micro_vert_loop ! end k loop - -! if (lprnt) write(0,*)' tlat3=',tlat(1,:)*deltat - !----------------------------------------------------- - ! convert rain/snow q and N for output to history, note, - ! output is for gridbox average - - do k=1,nlev - do i=1,mgncol - qrout(i,k) = qr(i,k) - nrout(i,k) = nr(i,k) * rho(i,k) - qsout(i,k) = qs(i,k) - nsout(i,k) = ns(i,k) * rho(i,k) -!++ag - qgout(i,k) = qg(i,k) - ngout(i,k) = ng(i,k) * rho(i,k) -!--ag - enddo - enddo - - ! calculate n0r and lamr from rain mass and number - ! divide by precip fraction to get in-precip (local) values of - ! rain mass and number, divide by rhow to get rain number in kg^-1 - - do k=1,nlev - - call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) - - enddo - ! Calculate rercld - - ! calculate mean size of combined rain and cloud water - - call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol, nlev) - - - ! Assign variables back to start-of-timestep values - ! Some state variables are changed before the main microphysics loop - ! to make "instantaneous" adjustments. Afterward, we must move those changes - ! back into the tendencies. - ! These processes: - ! - Droplet activation (npccn, impacts nc) - ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) - ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) - !================================================================================ - - do k=1,nlev - do i=1,mgncol - ! Re-apply droplet activation tendency - nc(i,k) = ncn(i,k) - nctend(i,k) = nctend(i,k) + npccn(i,k) - - ! Re-apply rain freezing and snow melting. - qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt - qs(i,k) = qsn(i,k) - - nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt - ns(i,k) = nsn(i,k) - - qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt - qr(i,k) = qrn(i,k) - - nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt - nr(i,k) = nrn(i,k) - -!++ag Re-apply graupel freezing/melting - qgtend(i,k) = qgtend(i,k) + (qg(i,k)-qgr(i,k)) * oneodt - qg(i,k) = qgr(i,k) - -! if (maxval(dum_2D-qg).gt.0._r8) & -! write(iulog,*) "OOPS, qg diff > 0 : max=",maxval(dum_2D-qg) -! if (minval(dum_2D-qg).lt.0._r8) & -! write(iulog,*) "OOPS, qg diff < 0 : min=",minval(dum_2D-qg) -! -! write(iulog,*) "Max qgtend: 1st = ",maxval(qgtend) -! write(iulog,*) "Min qgtend: 1st = ",minval(qgtend) -! write(iulog,*) "Max qvtend: 1st = ",maxval(qvlat) -! write(iulog,*) "Min qvtend: 1st = ",minval(qvlat) - - ngtend(i,k) = ngtend(i,k) + (ng(i,k)-ngr(i,k)) * oneodt - ng(i,k) = ngr(i,k) -!--ag - - !............................................................................. - - !================================================================================ - - ! modify to include snow. in prain & evap (diagnostic here: for wet dep) - nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) - prain(i,k) = prain(i,k) + prodsnow(i,k) - - - enddo - enddo - - do k=1,nlev - - do i=1,mgncol - - ! calculate sedimentation for cloud water and ice -!++ag ! and Graupel (mg3) - !================================================================================ - - ! update in-cloud cloud mixing ratio and number concentration - ! with microphysical tendencies to calculate sedimentation, assign to dummy vars - ! note: these are in-cloud values***, hence we divide by cloud fraction - - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) * tx1 - dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k) - end if - else - dumc(i,k) = zero - dumnc(i,k) = zero - endif - if (icldm(i,k) > mincld) then - tx1 = one / icldm(i,k) - dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) * tx1 - dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx1, zero) - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k) - end if - else - dumi(i,k) = zero - dumni(i,k) = zero - endif - if (precip_frac(i,k) > mincld) then - tx1 = one / precip_frac(i,k) - dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) * tx1 - dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) * tx1 - - dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)*tx1, zero) - dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)*tx1, zero) - -!++ag Add graupel - dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 -! Moorthi testing - if (dumg(i,k) > 0.01_r8) then - tx2 = dumg(i,k) - 0.01_r8 - dumg(i,k) = 0.01_r8 - dums(i,k) = dums(i,k) + tx2 - qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt - qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt - endif -! Moorthi testing - - dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)*tx1, zero) - ! switch for specification of droplet and crystal number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k) - endif -!--ag - else - dumr(i,k) = zero - dumr(i,k) = zero - dums(i,k) = zero - dumns(i,k) = zero -!++ag Add graupel - dumg(i,k) = zero - dumng(i,k) = zero - endif -!--ag - enddo - enddo - - do k=1,nlev - -! obtain new slope parameter to avoid possible singularity - - call size_dist_param_ice(mg_ice_props, dumi(:,k), dumni(:,k), & - lami(:,k), mgncol) - - call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & - pgam(:,k), lamc(:,k), mgncol) - -! call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & -! lami(:,k), mgncol) -! fallspeed for rain - - call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & - lamr(:,k), mgncol) -! fallspeed for snow - call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & - lams(:,k), mgncol) -! fallspeed for graupel/hail - if (do_graupel .or. do_hail) then - call size_dist_param_basic(mg_graupel_props, dumg(:,k), dumng(:,k), & - lamg(:,k), mgncol) - endif - enddo - - do k=1,nlev - do i=1,mgncol - - ! calculate number and mass weighted fall velocity for droplets and cloud ice - !------------------------------------------------------------------- - - grho = g*rho(i,k) - - if (dumc(i,k) >= qsmall) then - - tx1 = lamc(i,k)**bc - vtrmc(i,k) = acn(i,k)*gamma(pgam(i,k)+four+bc) & - / (tx1*gamma(pgam(i,k)+four)) - - fc(i,k) = grho * vtrmc(i,k) - fnc(i,k) = grho * acn(i,k)*gamma(pgam(i,k)+one+bc) & - / (tx1*gamma(pgam(i,k)+one)) - else - fc(i,k) = zero - fnc(i,k) = zero - end if - - ! calculate number and mass weighted fall velocity for cloud ice - - if (dumi(i,k) >= qsmall) then - - tx3 = one / lami(i,k) - tx1 = ain(i,k) * tx3**bi - tx2 = 1.2_r8*rhof(i,k) - vtrmi(i,k) = min(tx1*gamma_bi_plus4*oneo6, tx2) - - fi(i,k) = grho * vtrmi(i,k) - fni(i,k) = grho * min(tx1*gamma_bi_plus1, tx2) - - ! adjust the ice fall velocity for smaller (r < 20 um) ice - ! particles (blend over 18-20 um) - irad = (1.5_r8 * 1e6_r8) * tx3 - ifrac = min(one, max(zero, (irad-18._r8)*half)) - - if (ifrac < one) then - tx1 = ajn(i,k) / lami(i,k)**bj - vtrmi(i,k) = ifrac*vtrmi(i,k) + (one-ifrac) * min(tx1*gamma_bj_plus4*oneo6, tx2) - - fi(i,k) = grho * vtrmi(i,k) - fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) - end if - else - fi(i,k) = zero - fni(i,k)= zero - end if - - ! fallspeed for rain - -! if (lamr(i,k) >= qsmall) then - if (dumr(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - - tx1 = arn(i,k) / lamr(i,k)**br - tx2 = 9.1_r8*rhof(i,k) - umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) - unr(i,k) = min(tx1*gamma_br_plus1, tx2) - - fr(i,k) = grho * umr(i,k) - fnr(i,k) = grho * unr(i,k) - - else - fr(i,k) = zero - fnr(i,k) = zero - end if - - ! fallspeed for snow - -! if (lams(i,k) >= qsmall) then - if (dums(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - tx1 = asn(i,k) / lams(i,k)**bs - tx2 = 1.2_r8*rhof(i,k) - ums(i,k) = min(tx1*gamma_bs_plus4*oneo6, tx2) - uns(i,k) = min(tx1*gamma_bs_plus1, tx2) - - fs(i,k) = grho * ums(i,k) - fns(i,k) = grho * uns(i,k) - - else - fs(i,k) = zero - fns(i,k) = zero - end if - - if (do_graupel .or. do_hail) then -!++ag - ! fallspeed for graupel - - -! if (lamg(i,k) >= qsmall) then - if (dumg(i,k) >= qsmall) then - - ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s) - tx1 = agn(i,k) / lamg(i,k)**bgtmp - tx2 = 20._r8 * rhof(i,k) - umg(i,k) = min(tx1*gamma_bg_plus4*oneo6, tx2) - ung(i,k) = min(tx1*gamma_bg_plus1, tx2) - - fg(i,k) = grho * umg(i,k) - fng(i,k) = grho * ung(i,k) - - else - fg(i,k) = zero - fng(i,k) = zero - end if - endif - - ! redefine dummy variables - sedimentation is calculated over grid-scale - ! quantities to ensure conservation - - dumc(i,k) = qc(i,k) + qctend(i,k)*deltat - dumi(i,k) = qi(i,k) + qitend(i,k)*deltat - dumr(i,k) = qr(i,k) + qrtend(i,k)*deltat - dums(i,k) = qs(i,k) + qstend(i,k)*deltat - - dumnc(i,k) = nc(i,k) + nctend(i,k)*deltat - dumni(i,k) = ni(i,k) + nitend(i,k)*deltat - dumnr(i,k) = nr(i,k) + nrtend(i,k)*deltat - dumns(i,k) = ns(i,k) + nstend(i,k)*deltat -!++ag - dumg(i,k) = qg(i,k) + qgtend(i,k)*deltat - dumng(i,k) = ng(i,k) + ngtend(i,k)*deltat -!--ag - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero - if (dumg(i,k) < qsmall) dumng(i,k) = zero - - enddo - end do !!! vertical loop - - do k=1,nlev - do i=1,mgncol - pdel_inv(i,k) = one / pdel(i,k) - enddo - enddo -! if (lprnt) write(0,*)' bef sedimentation dumc=',dumc(i,nlev-10:nlev) - - ! initialize nstep for sedimentation sub-steps - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - do i=1,mgncol - nlb = nlball(i) - nstep = 1 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - if (do_cldice) then - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumi(i,k) = tx5 / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = tx5 / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qisedten(i,k) = qisedten(i,k) + tx6 - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - - do k = 2,nlev - - ! for cloud liquid and ice, if cloud fraction increases with height - ! then add flux from above to both vapor and cloud water of current level - ! this means that flux entering clear portion of cell from above evaporates - ! instantly - - ! note: this is not an issue with precip, since we assume max overlap - - if (icldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumi(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (one + fi(i,k)*tx7) - tx6 = (dumi(i,k)-tx5) * oneodt - ! add fallout terms to eulerian tendencies - qitend(i,k) = qitend(i,k) + tx6 - tx5 = dumni(i,k) - dumni(i,k) = (tx5 + faloutni(k-1)*dum2) / (one + fni(i,k)*tx7) - nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt - - - qisedten(i,k) = qisedten(i,k) + tx6 ! sedimentation tendency for output - - - falouti(k) = fi(i,k) * dumi(i,k) - faloutni(k) = fni(i,k) * dumni(i,k) - - dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice - qisevap(i,k) = qisevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxls - - iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux - end do - - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - - prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) - - end do - end if - -! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - - do n = 1,nstep - - ! top of model - k = 1 - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumc(i,k) = tx5 / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = tx5 / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - ! sedimentation tendency for output - qcsedten(i,k) = qcsedten(i,k) + tx6 - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 - do k = 2,nlev - - if (lcldm(i,k-1) > mincld) then - dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) - else - dum1 = one - endif - - tx5 = dumc(i,k) - tx7 = pdel_inv(i,k) * tx1 - dum2 = tx7 * dum1 - dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (one + fc(i,k)*tx7) - tx6 = (dumc(i,k)-tx5) * oneodt - qctend(i,k) = qctend(i,k) + tx6 - tx5 = dumnc(i,k) - dumnc(i,k) = (tx5 + faloutnc(k-1)*dum2) / (one + fnc(i,k)*tx7) - nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt - - - - qcsedten(i,k) = qcsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutc(k) = fc(i,k) * dumc(i,k) - faloutnc(k) = fnc(i,k) * dumnc(i,k) - - dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 - qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water - qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output - - tlat(i,k) = tlat(i,k) - dum2 * xxlv - - lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here - end do - - prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) - - end do -! if (lprnt) write(0,*)' tlat5=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& -! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - - nstep = min(nstep, nstep_def) - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - -! if(lprnt) then -! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall -! write(0,*)' fr=',fr(i,:) -! write(0,*)' dumr=',dumr(i,:) -! endif - - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = tx5 / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = tx5 / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qrsedten(i,k) = qrsedten(i,k) + tx6 - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 - - do k = 2,nlev - - tx5 = dumr(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumr(i,k) = (tx5 + faloutr(k-1)*tx7) / (one + fr(i,k)*tx7) - tx6 = (dumr(i,k)-tx5) * oneodt - qrtend(i,k) = qrtend(i,k) + tx6 - tx5 = dumnr(i,k) - dumnr(i,k) = (tx5 + faloutnr(k-1)*tx7) / (one + fnr(i,k)*tx7) - nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt - - qrsedten(i,k) = qrsedten(i,k) + tx6 ! sedimentation tendency for output - - faloutr(k) = fr(i,k) * dumr(i,k) - faloutnr(k) = fnr(i,k) * dumnr(i,k) - - rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux - end do - - prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) - - end do - -! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) - - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = tx5 / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = tx5 / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qssedten(i,k) = qssedten(i,k) + tx6 - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 - - do k = 2,nlev - - - tx5 = dums(i,k) - tx7 = pdel_inv(i,k) * tx1 - dums(i,k) = (tx5 + falouts(k-1)*tx7) / (one + fs(i,k)*tx7) - tx6 = (dums(i,k)-tx5) * oneodt - qstend(i,k) = qstend(i,k) + tx6 - tx5 = dumns(i,k) - dumns(i,k) = (tx5 + faloutns(k-1)*tx7) / (one + fns(i,k)*tx7) - nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt - - - qssedten(i,k) = qssedten(i,k) + tx6 ! sedimentation tendency for output - - falouts(k) = fs(i,k) * dums(i,k) - faloutns(k) = fns(i,k) * dumns(i,k) - - sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 ! Snow Flux - end do !! k loop - - prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) - - end do !! nstep loop - -! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) -! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) - - if (do_graupel .or. do_hail) then -!++ag Graupel Sedimentation - ! calculate number of split time steps to ensure courant stability criteria - ! for sedimentation calculations - !------------------------------------------------------------------- - nstep = 1 + nint(max( maxval( fg(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & - maxval(fng(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) - nstep = min(nstep, nstep_def) - - tx2 = one / nstep - tx1 = tx2 * deltat - tx3 = tx2 / g - ! loop over sedimentation sub-time step to ensure stability - !============================================================== - do n = 1,nstep - - ! top of model - k = 1 - - ! add fallout terms to microphysical tendencies - - tx5 = dumg(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumg(i,k) = tx5 / (one + fg(i,k)*tx7) - tx6 = (dumg(i,k)-tx5) * oneodt - qgtend(i,k) = qgtend(i,k) + tx6 - tx5 = dumng(i,k) - dumng(i,k) = tx5 / (one + fng(i,k)*tx7) - ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt - - ! sedimentation tendency for output - qgsedten(i,k) = qgsedten(i,k) + tx6 - - faloutg(k) = fg(i,k) * dumg(i,k) - faloutng(k) = fng(i,k) * dumng(i,k) - - gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - - do k = 2,nlev - - tx5 = dumg(i,k) - tx7 = pdel_inv(i,k) * tx1 - dumg(i,k) = (tx5 + faloutg(k-1)*tx7) / (one + fg(i,k)*tx7) - tx6 = (dumg(i,k)-tx5) * oneodt - ! add fallout terms to eulerian tendencies - qgtend(i,k) = qgtend(i,k) + tx6 - tx5 = dumng(i,k) - dumng(i,k) = (tx5 + faloutng(k-1)*tx7) / (one + fng(i,k)*tx7) - ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt - - - qgsedten(i,k) = qgsedten(i,k) + tx6 ! sedimentation tendency for output - - - faloutg(k) = fg(i,k) * dumg(i,k) - faloutng(k) = fng(i,k) * dumng(i,k) - - gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux - end do - - ! units below are m/s - ! sedimentation flux at surface is added to precip flux at surface - ! to get total precip (cloud + precip water) rate - - prect(i) = prect(i) + faloutg(nlev) * (tx3*0.001_r8) - preci(i) = preci(i) + faloutg(nlev) * (tx3*0.001_r8) - - end do !! nstep loop - endif -! if (lprnt) write(0,*)' qgtnds=',qgtend(1,:) -!--ag - enddo ! end of i loop - ! end sedimentation - -! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) - - !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - ! get new update for variables that includes sedimentation tendency - ! note : here dum variables are grid-average, NOT in-cloud - - do k=1,nlev - do i=1,mgncol - dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) - dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) - dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) - dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) - -!++ag - dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) -! Moorthi testing - if (dumg(i,k) > 0.01_r8) then - tx2 = dumg(i,k) - 0.01_r8 - dumg(i,k) = 0.01_r8 - dums(i,k) = dums(i,k) + tx2 - qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt - qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt - endif -! Moorthi testing - dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) -!--ag - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) - end if - -!++ag - ! switch for specification of graupel number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) - end if -!--ag - - if (dumc(i,k) < qsmall) dumnc(i,k) = zero - if (dumi(i,k) < qsmall) dumni(i,k) = zero - if (dumr(i,k) < qsmall) dumnr(i,k) = zero - if (dums(i,k) < qsmall) dumns(i,k) = zero -!++ag - if (dumg(i,k) < qsmall) dumng(i,k) = zero -!--ag - - enddo - - enddo - - ! calculate instantaneous processes (melting, homogeneous freezing) - !==================================================================== - - ! melting of snow at +2 C - do k=1,nlev - - do i=1,mgncol - - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt - if (tx1 > zero) then - if (dums(i,k) > zero) then - - ! make sure melting snow doesn't reduce temperature below threshold - dum = -(xlf/cpp) * dums(i,k) - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - qstend(i,k) = qstend(i,k) - tx2*dums(i,k) - nstend(i,k) = nstend(i,k) - tx2*dumns(i,k) - qrtend(i,k) = qrtend(i,k) + tx2*dums(i,k) - nrtend(i,k) = nrtend(i,k) + tx2*dumns(i,k) - - dum1 = - xlf * tx2 * dums(i,k) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if - enddo - enddo - - if (do_graupel .or. do_hail) then -!++ag - - ! melting of graupel at +2 C - - do k=1,nlev - - do i=1,mgncol - - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt - if (tx1 > zero) then - if (dumg(i,k) > zero) then - - ! make sure melting graupel doesn't reduce temperature below threshold - dum = -(xlf/cpp) * dumg(i,k) - if (tx1+dum < zero) then - dum = max(zero, min(one, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - - qgtend(i,k) = qgtend(i,k) - tx2*dumg(i,k) - ngtend(i,k) = ngtend(i,k) - tx2*dumng(i,k) - qrtend(i,k) = qrtend(i,k) + tx2*dumg(i,k) - nrtend(i,k) = nrtend(i,k) + tx2*dumng(i,k) - - dum1 = - xlf*tx2*dumg(i,k) - tlat(i,k) = dum1 + tlat(i,k) - meltsdttot(i,k) = dum1 + meltsdttot(i,k) - end if - end if - enddo - enddo - -!--ag - endif - - do k=1,nlev - do i=1,mgncol - - ! freezing of rain at -5 C - - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - rainfrze - if (tx1 < zero) then - - if (dumr(i,k) > zero) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = (xlf/cpp) * dumr(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - tx2 = dum * oneodt - qrtend(i,k) = qrtend(i,k) - tx2 * dumr(i,k) - nrtend(i,k) = nrtend(i,k) - tx2 * dumnr(i,k) - - ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice - ! depending on mean rain size - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (lamr(i,k) < one/Dcs) then -!++ag freeze rain to graupel - if (do_hail .or. do_graupel) then - qgtend(i,k) = qgtend(i,k) + tx2 * dumr(i,k) - ngtend(i,k) = ngtend(i,k) + tx2 * dumnr(i,k) - else - qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) - nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) - end if -!--ag - else - qitend(i,k) = qitend(i,k) + tx2 * dumr(i,k) - nitend(i,k) = nitend(i,k) + tx2 * dumnr(i,k) - end if - ! heating tendency - dum1 = xlf*dum*dumr(i,k)*oneodt - frzrdttot(i,k) = dum1 + frzrdttot(i,k) - tlat(i,k) = dum1 + tlat(i,k) - - end if - end if - - enddo - enddo - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - tmelt - if (tx1 > zero) then - if (dumi(i,k) > zero) then - - ! limit so that melting does not push temperature below freezing - !----------------------------------------------------------------- - dum = -dumi(i,k)*xlf/cpp - if (tx1+dum < zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt - qctend(i,k) = qctend(i,k) + tx2*dumi(i,k) - - ! for output - melttot(i,k) = tx2*dumi(i,k) - - ! assume melting ice produces droplet - ! mean volume radius of 8 micron - - nctend(i,k) = nctend(i,k) + three*tx2*dumi(i,k)/(four*pi*5.12e-16_r8*rhow) - - qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt - nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt - tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) - end if - end if - enddo - enddo - -! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat -! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-45:nlev)*deltat -! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-45:nlev)*deltat - - ! homogeneously freeze droplets at -40 C - !----------------------------------------------------------------- - - do k=1,nlev - do i=1,mgncol - tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - 233.15_r8 - if (tx1 < zero) then - if (dumc(i,k) > zero) then - - ! limit so that freezing does not push temperature above threshold - dum = (xlf/cpp) * dumc(i,k) - if (tx1+dum > zero) then - dum = min(one, max(zero, -tx1/dum)) - else - dum = one - end if - - tx2 = dum * oneodt * dumc(i,k) - qitend(i,k) = tx2 + qitend(i,k) - homotot(i,k) = tx2 ! for output - - ! assume 25 micron mean volume radius of homogeneously frozen droplets - ! consistent with size of detrained ice in stratiform.F90 - - nitend(i,k) = nitend(i,k) + tx2*(three/(four*pi*1.563e-14_r8* 500._r8)) - qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt - nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt - tlat(i,k) = tlat(i,k) + xlf*tx2 - end if - end if - enddo - enddo - ! remove any excess over-saturation, which is possible due to non-linearity when adding - ! together all microphysical processes - !----------------------------------------------------------------- - ! follow code similar to old CAM scheme - do k=1,nlev - do i=1,mgncol - - qtmp = q(i,k) + qvlat(i,k) * deltat - ttmp = t(i,k) + tlat(i,k) * (deltat/cpp) - - ! use rhw to allow ice supersaturation - !call qsat_water(ttmp, p(i,k), esn, qvn) - esn = min(fpvsl(ttmp), p(i,k)) - qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) -! qvn = epsqs*esn/(p(i,k)-omeps*esn) - - - if (qtmp > qvn .and. qvn > zero .and. allow_sed_supersat) then - ! expression below is approximate since there may be ice deposition - dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - ! add to output cme - cmeout(i,k) = cmeout(i,k) + dum - ! now add to tendencies, partition between liquid and ice based on temperature - if (ttmp > 268.15_r8) then - dum1 = zero - ! now add to tendencies, partition between liquid and ice based on te - !------------------------------------------------------- - else if (ttmp < 238.15_r8) then - dum1 = one - else - dum1 = (268.15_r8-ttmp)/30._r8 - end if - - tx1 = xxls*dum1 + xxlv*(one-dum1) - dum = (qtmp-qvn)/(one+tx1*tx1*qvn/(cpp*rv*ttmp*ttmp)) * oneodt - tx2 = dum*(one-dum1) - qctend(i,k) = qctend(i,k) + tx2 - qcrestot(i,k) = tx2 ! for output - qitend(i,k) = qitend(i,k) + dum*dum1 - qirestot(i,k) = dum*dum1 - qvlat(i,k) = qvlat(i,k) - dum - ! for output - qvres(i,k) = -dum - tlat(i,k) = tlat(i,k) + dum*tx1 - end if - enddo - enddo - end if - -! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat - - ! calculate effective radius for pass to radiation code - !========================================================= - ! if no cloud water, default value is 10 micron for droplets, - ! 25 micron for cloud ice - - ! update cloud variables after instantaneous processes to get effective radius - ! variables are in-cloud to calculate size dist parameters - do k=1,nlev - do i=1,mgncol - if (lcldm(i,k) > mincld) then - tx1 = one / lcldm(i,k) - else - tx1 = zero - endif - if (icldm(i,k) > mincld) then - tx2 = one / icldm(i,k) - else - tx2 = zero - endif - if (precip_frac(i,k) > mincld) then - tx3 = one / precip_frac(i,k) - else - tx3 = zero - endif - dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) * tx1 - dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) * tx2 - dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) * tx1 - dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) * tx2 - - dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) * tx3 - dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) * tx3 - dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) * tx3 - dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) * tx3 - -!++ag - dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) * tx3 - dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) * tx3 -!--ag - - ! switch for specification of droplet and crystal number - if (nccons) then - dumnc(i,k) = ncnst * rhoinv(i,k) - end if - - ! switch for specification of cloud ice number - if (nicons) then - dumni(i,k) = ninst * rhoinv(i,k) - end if - -!++ag - ! switch for specification of graupel number - if (ngcons) then - dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) - end if -!--ag - - ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 -! dumc(i,k) = min(dumc(i,k), 5.e-3_r8) -! dumi(i,k) = min(dumi(i,k), 5.e-3_r8) - dumc(i,k) = min(dumc(i,k), 10.e-3_r8) - dumi(i,k) = min(dumi(i,k), 10.e-3_r8) - ! limit in-precip mixing ratios - dumr(i,k) = min(dumr(i,k), 10.e-3_r8) - dums(i,k) = min(dums(i,k), 10.e-3_r8) -!++ag - dumg(i,k) = min(dumg(i,k), 10.e-3_r8) -!--ag - enddo - enddo - ! cloud ice effective radius - !----------------------------------------------------------------- - - if (do_cldice) then - do k=1,nlev - do i=1,mgncol - if (dumi(i,k) >= qsmall) then - - tx1 = dumni(i,k) - call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & - lami(i,k), dumni0) - - if (dumni(i,k) /= tx1) then - ! adjust number conc if needed to keep mean size in reasonable range - nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k)) * oneodt - end if - - tx1 = one / lami(i,k) -! effi(i,k) = (1.5_r8*1.e6_r8) * tx1 - effi(i,k) = (three*1.e6_r8) * tx1 - sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 - - else - effi(i,k) = 50._r8 - sadice(i,k) = zero - end if - - ! ice effective diameter for david mitchell's optics - deffi(i,k) = effi(i,k) * (rhoi+rhoi)/rhows - enddo - enddo - !else - !do k=1,nlev - !do i=1,mgncol - ! NOTE: If CARMA is doing the ice microphysics, then the ice effective - ! radius has already been determined from the size distribution. - !effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um - !deffi(i,k)=effi(i,k) * 2._r8 - !sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 - !enddo - !enddo - end if - - ! cloud droplet effective radius - !----------------------------------------------------------------- - do k=1,nlev - do i=1,mgncol - if (dumc(i,k) >= qsmall) then - - - ! switch for specification of droplet and crystal number - if (nccons) then - ! make sure nc is consistence with the constant N by adjusting tendency, need - ! to multiply by cloud fraction - ! note that nctend may be further adjusted below if mean droplet size is - ! out of bounds - - nctend(i,k) = (ncnst*rhoinv(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - - end if - - dum = dumnc(i,k) - - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - if (dum /= dumnc(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k)) * oneodt - end if - - effc(i,k) = (half*1.e6_r8) * (pgam(i,k)+three) / lamc(i,k) - !assign output fields for shape here - lamcrad(i,k) = lamc(i,k) - pgamrad(i,k) = pgam(i,k) - - - ! recalculate effective radius for constant number, in order to separate - ! first and second indirect effects - !====================================== - ! assume constant number of 10^8 kg-1 - - dumnc(i,k) = 1.e8_r8 - - ! Pass in "false" adjust flag to prevent number from being changed within - ! size distribution subroutine. - call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & - pgam(i,k), lamc(i,k)) - - effc_fn(i,k) = (half*1.e6_r8) * (pgam(i,k)+three)/lamc(i,k) - - else - effc(i,k) = ten - lamcrad(i,k) = zero - pgamrad(i,k) = zero - effc_fn(i,k) = ten - end if - enddo - enddo - ! recalculate 'final' rain size distribution parameters - ! to ensure that rain size is in bounds, adjust rain number if needed - do k=1,nlev - do i=1,mgncol - - if (dumr(i,k) >= qsmall) then - - dum = dumnr(i,k) - - call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) - - if (dum /= dumnr(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt - end if - - end if - enddo - enddo - ! recalculate 'final' snow size distribution parameters - ! to ensure that snow size is in bounds, adjust snow number if needed - do k=1,nlev - do i=1,mgncol - if (dums(i,k) >= qsmall) then - - dum = dumns(i,k) - - call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & - lams(i,k), n0=dumns0) - - if (dum /= dumns(i,k)) then - ! adjust number conc if needed to keep mean size in reasonable range - nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k)) * oneodt - end if - - tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) - sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 - - end if - - - end do ! vertical k loop - enddo - do k=1,nlev - do i=1,mgncol - ! if updated q (after microphysics) is zero, then ensure updated n is also zero - !================================================================================= - if (qc(i,k)+qctend(i,k)*deltat < qsmall) nctend(i,k) = -nc(i,k) * oneodt - if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat < qsmall) nitend(i,k) = -ni(i,k) * oneodt - if (qr(i,k)+qrtend(i,k)*deltat < qsmall) nrtend(i,k) = -nr(i,k) * oneodt - if (qs(i,k)+qstend(i,k)*deltat < qsmall) nstend(i,k) = -ns(i,k) * oneodt -!++ag - if (qg(i,k)+qgtend(i,k)*deltat < qsmall) ngtend(i,k) = -ng(i,k) * oneodt -!--ag - - end do - - end do - - ! DO STUFF FOR OUTPUT: - !================================================== - - do k=1,nlev - do i=1,mgncol - - ! qc and qi are only used for output calculations past here, - ! so add qctend and qitend back in one more time - qc(i,k) = qc(i,k) + qctend(i,k)*deltat - qi(i,k) = qi(i,k) + qitend(i,k)*deltat - - ! averaging for snow and rain number and diameter - !-------------------------------------------------- - - ! drout2/dsout2: - ! diameter of rain and snow - ! dsout: - ! scaled diameter of snow (passed to radiation in CAM) - ! reff_rain/reff_snow: - ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual - - if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then - qrout2(i,k) = qrout(i,k) * precip_frac(i,k) - nrout2(i,k) = nrout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just drout2 times constants. - drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) - freqr(i,k) = precip_frac(i,k) - - reff_rain(i,k) = (1.e6_r8*1.5_r8) * drout2(i,k) - else - qrout2(i,k) = zero - nrout2(i,k) = zero - drout2(i,k) = zero - freqr(i,k) = zero - reff_rain(i,k) = zero - endif - - if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then - qsout2(i,k) = qsout(i,k) * precip_frac(i,k) - nsout2(i,k) = nsout(i,k) * precip_frac(i,k) - ! The avg_diameter call does the actual calculation; other diameter - ! outputs are just dsout2 times constants. - dsout2(i,k) = avg_diameter(qsout(i,k), nsout(i,k), rho(i,k), rhosn) - freqs(i,k) = precip_frac(i,k) - - dsout(i,k) = three*rhosn/rhows*dsout2(i,k) - - reff_snow(i,k) = (1.e6_r8*three) * dsout2(i,k) - else - dsout(i,k) = zero - qsout2(i,k) = zero - nsout2(i,k) = zero - dsout2(i,k) = zero - freqs(i,k) = zero - reff_snow(i,k) = zero - endif - - enddo - enddo - - ! analytic radar reflectivity - !-------------------------------------------------- - ! formulas from Matthew Shupe, NOAA/CERES - ! *****note: radar reflectivity is local (in-precip average) - ! units of mm^6/m^3 - - do k=1,nlev - do i = 1,mgncol -! if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten .and. lcldm(i,k) > mincld) then - if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten) then - tx1 = rho(i,k) / lcldm(i,k) - tx2 = 1000._r8 * qc(i,k) * tx1 - dum = tx2 * tx2 * lcldm(i,k) & - /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)*tx1*1.e-6_r8*precip_frac(i,k)) -! dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & -! /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) - else - dum = zero - end if -! if (qi(i,k) >= qsmall .and. icldm(i,k) > mincld) then - if (qi(i,k) >= qsmall) then -! dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) - dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*10000._r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) - else - dum1 = zero - end if - - if (qsout(i,k) >= qsmall) then -! dum1 = dum1 + (qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(one/0.63_r8) - dum1 = dum1 + (qsout(i,k)*rho(i,k)*10000._r8)**(one/0.63_r8) - end if - - refl(i,k) = dum + dum1 - - ! add rain rate, but for 37 GHz formulation instead of 94 GHz - ! formula approximated from data of Matrasov (2007) - ! rainrt is the rain rate in mm/hr - ! reflectivity (dum) is in DBz - - if (rainrt(i,k) >= 0.001_r8) then - dum = rainrt(i,k) * rainrt(i,k) - dum = log10(dum*dum*dum) + 16._r8 - - ! convert from DBz to mm^6/m^3 - - dum = ten**(dum/ten) - else - ! don't include rain rate in R calculation for values less than 0.001 mm/hr - dum = zero - end if - - ! add to refl - - refl(i,k) = refl(i,k) + dum - - !output reflectivity in Z. - areflz(i,k) = refl(i,k) * precip_frac(i,k) - - ! convert back to DBz - - if (refl(i,k) > minrefl) then - refl(i,k) = ten*log10(refl(i,k)) - else - refl(i,k) = -9999._r8 - end if - - !set averaging flag - if (refl(i,k) > mindbz) then - arefl(i,k) = refl(i,k) * precip_frac(i,k) - frefl(i,k) = precip_frac(i,k) - else - arefl(i,k) = zero - areflz(i,k) = zero - frefl(i,k) = zero - end if - - ! bound cloudsat reflectivity - - csrfl(i,k) = min(csmax,refl(i,k)) - - !set averaging flag - if (csrfl(i,k) > csmin) then - acsrfl(i,k) = refl(i,k) * precip_frac(i,k) - fcsrfl(i,k) = precip_frac(i,k) - else - acsrfl(i,k) = zero - fcsrfl(i,k) = zero - end if - - end do - end do - - do k=1,nlev - do i = 1,mgncol - !redefine fice here.... - tx2 = qsout(i,k) + qi(i,k) - tx1 = tx2 + qrout(i,k) + qc(i,k) - if ( tx2 > qsmall .and. tx1 > qsmall) then - nfice(i,k) = min(tx2/tx1, one) - else - nfice(i,k) = zero - endif - enddo - enddo - -end subroutine micro_mg_tend -!> @} - -!======================================================================== -!OUTPUT CALCULATIONS -!======================================================================== - -!>\ingroup mg3_mp -!! This subroutine calculates effective radii for rain and cloud. -subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) - 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 - - integer :: i, k - - do k=1,nlev - do i=1,mgncol - ! Rain drops - if (lamr(i,k) > zero) then - Atmp = n0r(i,k) * (half*pi) / (lamr(i,k)*lamr(i,k)*lamr(i,k)) - else - Atmp = zero - end if - - ! Add cloud drops - if (lamc(i,k) > zero) then - Atmp = Atmp + ncic(i,k) * pi * rising_factorial(pgam(i,k)+one, 2) & - / (four*lamc(i,k)*lamc(i,k)) - end if - - if (Atmp > zero) then - rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) - end if - enddo - enddo -end subroutine calc_rercld - -!======================================================================== - -end module micro_mg3_0 -!>@} From a1c06bab4ed9106b7d9e8d6b0506435bc54e6884 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 18:58:00 +0000 Subject: [PATCH 129/165] removing accidental commenting in GFS_surface_composites.F90 --- physics/GFS_surface_composites.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index b45b64629..39706cdea 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -202,7 +202,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water -! uustar_wat(i) = uustar(i) + uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) !-- reference emiss value for surface emissivity in setemis From dda209cdd5e9bb67decea7a9a1e7ed7a3e94f55d Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 19:24:05 +0000 Subject: [PATCH 130/165] putting the comment back on uustar_wat as is is computed in sfc_diff.f for water --- physics/GFS_surface_composites.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 39706cdea..b45b64629 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -202,7 +202,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water - uustar_wat(i) = uustar(i) +! uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) !-- reference emiss value for surface emissivity in setemis From bdfefddd73ee580c7c79d7ded4be81a8e1c7c27d Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Wed, 9 Jun 2021 19:30:57 +0000 Subject: [PATCH 131/165] update sfc_diff with zvfun --- physics/sfc_diff.f | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index d797e2176..0cd373b87 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -290,6 +290,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) if (icy(i)) then ! Some ice + zvfun(i) = zero + if(thsfc_loc) then ! Use local potential temperature tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac else ! Use potential temperature referenced to 1000 hPa @@ -342,6 +344,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! the stuff now put into "stability" if (wet(i)) then ! Some open ocean + + zvfun(i) = zero if(thsfc_loc) then ! Use local potential temperature tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac From 445e3edf0495c63e9f6f8d65bd07889787a73273 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Wed, 9 Jun 2021 19:49:26 +0000 Subject: [PATCH 132/165] update GFS_surface_composites with canopy heat storage variables in the fractional grid --- physics/GFS_surface_composites.F90 | 29 ++++++++++++++++++++++++++--- 1 file changed, 26 insertions(+), 3 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 31becefa4..973286d93 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -382,13 +382,15 @@ subroutine GFS_surface_composites_post_run ( cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, sigmaf, zvfun, stc, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, & + sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) implicit none integer, intent(in) :: im, kice, km logical, intent(in) :: cplflx, frac_grid, cplwav2atm + logical, intent(in) :: lheatstrg logical, dimension(:), intent(in) :: flag_cice, dry, wet, icy integer, dimension(:), intent(in) :: islmsk real(kind=kind_phys), dimension(:), intent(in) :: wind, t1, q1, prsl1, landfrac, lakefrac, oceanfrac, & @@ -404,7 +406,8 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys), dimension(:), intent(in ) :: tice ! interstitial sea ice temperature real(kind=kind_phys), dimension(:), intent(inout) :: hice, cice - real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun + real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun, hflxq, hffac + real(kind=kind_phys), intent(in ) :: h0facu, h0facs real(kind=kind_phys), intent(in ) :: min_seaice real(kind=kind_phys), intent(in ) :: rd, rvrdm1 @@ -532,13 +535,33 @@ subroutine GFS_surface_composites_post_run ( uustar(i) = uustar_ice(i) else ! Mix of multiple surface types (land, water, and/or ice) ! -! compute zvfun with composite surface roughness & green vegetation fraction +! re-compute zvfun with composite surface roughness & green vegetation fraction ! tem1 = (z0max - z0lo) / (z0up - z0lo) tem1 = min(max(tem1, zero), one) tem2 = max(sigmaf(i), 0.1) zvfun(i) = sqrt(tem1 * tem2) gdx = sqrt(garea(i)) +! +! re-compute variables for canopy heat storage parameterization with the updated zvfun +! in the fractional grid +! +! + do i=1,im + hflxq(i) = hflx(i) + hffac(i) = 1.0 + enddo + if (lheatstrg) then + do i=1,im + if(hflx(i) > 0.) then + hffac(i) = h0facu * zvfun(i) + else + hffac(i) = h0facs * zvfun(i) + endif + hffac(i) = 1. + hffac(i) + hflxq(i) = hflx(i) / hffac(i) + enddo + endif ! call stability(z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & ! inputs z0max, ztmax, tvs, grav, thsfc_loc, & ! inputs From 9e62687333a589621cf3f3a3e46dcb7e18ad54df Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Wed, 9 Jun 2021 19:53:54 +0000 Subject: [PATCH 133/165] update GFS_surface_composites with canopy heat storage variables in the fractional grid --- physics/GFS_surface_composites.meta | 44 +++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 88dae1ae4..73ca42982 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -1937,6 +1937,50 @@ kind = kind_phys intent = inout optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[h0facu] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_unstable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in unstable surface layer + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[h0facs] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_stable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in stable surface layer + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hflxq] + standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness_and_vegetation + long_name = kinematic surface upward sensible heat flux reduced by surface roughness and vegetation + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[hffac] + standard_name = surface_upward_sensible_heat_flux_reduction_factor + long_name = surface upward sensible heat flux reduction factor from canopy heat storage + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [sigmaf] standard_name = bounded_vegetation_area_fraction long_name = areal fractional cover of green vegetation bounded on the bottom From 964fe63b264733b6bccccad1756120c03814d255 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Wed, 9 Jun 2021 21:07:34 +0000 Subject: [PATCH 134/165] replace islmsk=1 with dry --- physics/GFS_surface_generic.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index b7e3843fb..353540b70 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -209,21 +209,21 @@ end subroutine GFS_surface_generic_post_finalize !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& + subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, dry, icy, wet, & + dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, & adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & - nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, islmsk, & + nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, errmsg, errflg) implicit none integer, intent(in) :: im - integer, dimension(im), intent(in) :: islmsk logical, intent(in) :: cplflx, cplwav, lssav - logical, dimension(:), intent(in) :: icy, wet + logical, dimension(:), intent(in) :: dry, icy, wet real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(:), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & @@ -369,7 +369,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt enddo if (lheatstrg) then do i=1,im - if(islmsk(i) == 1) then + if (dry(i)) then if(hflx(i) > 0.) then hffac(i) = h0facu * zvfun(i) else From 9da3165bccdbf75a024905688772ce51d3bdab8b Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Wed, 9 Jun 2021 21:11:12 +0000 Subject: [PATCH 135/165] add dry --- physics/GFS_surface_generic.meta | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index e6393f228..fbdb59fcc 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -504,6 +504,14 @@ type = logical intent = in optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F [icy] standard_name = flag_nonzero_sea_ice_surface_fraction long_name = flag indicating presence of some sea ice surface area fraction @@ -1213,14 +1221,6 @@ kind = kind_phys intent = inout optional = F -[islmsk] - standard_name = sea_land_ice_mask - long_name = landmask: sea/land/ice=0/1/2 - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F [runoff] standard_name = total_runoff long_name = total water runoff From d77e916c90f8cfcfc9a25dfd1e86cf83e6c7677c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 23:58:37 +0000 Subject: [PATCH 136/165] Updating GFS_surface_composites.F90 to use log in compositing zorl between water and ice following Ben Green's suggestion and removng a comment from gcycle --- physics/GFS_surface_composites.F90 | 9 ++------- physics/gcycle.F90 | 1 - 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index b45b64629..4671d9642 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -720,15 +720,10 @@ subroutine GFS_surface_composites_post_run ( stress(i) = txi * stress_ice(i) + txo * stress_wat(i) qss(i) = txi * qss_ice(i) + txo * qss_wat(i) ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) - zorl(i) = txi * zorli(i) + txo * zorlo(i) -! zorl(i) = txi * log(zorli(i)) + txo * log(zorlo(i)) -! zorl(i) = exp(zorl(i)) -! snowd(i) = txi * snowd_ice(i) + zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) endif elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array - zorl(i) = cice(i)*zorli(i) + (one-cice(i))*zorlo(i) -! zorl(i) = cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i)) -! zorl(i) = exp(zorl(i)) + zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) endif ! if (wet(i)) then diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 4a60337ec..718b375af 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -127,7 +127,6 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, if (landfrac(ix) > -1.0e-8_kind_phys) then slmskl(ix) = ceiling(landfrac(ix)-1.0e-8_kind_phys) slmskw(ix) = floor(landfrac(ix)+1.0e-8_kind_phys) -! slmskw(ix) = slmskl(ix) else if (nint(slmsk(ix)) == 1) then slmskl(ix) = 1.0_kind_phys From a7995e39f58775d678112044f4d1af4496e1cfa6 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Thu, 10 Jun 2021 02:27:10 +0000 Subject: [PATCH 137/165] fix a bug --- physics/GFS_surface_composites.F90 | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 973286d93..9feb5f25e 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -545,22 +545,17 @@ subroutine GFS_surface_composites_post_run ( ! ! re-compute variables for canopy heat storage parameterization with the updated zvfun ! in the fractional grid -! ! - do i=1,im - hflxq(i) = hflx(i) - hffac(i) = 1.0 - enddo + hflxq(i) = hflx(i) + hffac(i) = 1.0 if (lheatstrg) then - do i=1,im - if(hflx(i) > 0.) then - hffac(i) = h0facu * zvfun(i) - else - hffac(i) = h0facs * zvfun(i) - endif - hffac(i) = 1. + hffac(i) - hflxq(i) = hflx(i) / hffac(i) - enddo + if(hflx(i) > 0.) then + hffac(i) = h0facu * zvfun(i) + else + hffac(i) = h0facs * zvfun(i) + endif + hffac(i) = 1. + hffac(i) + hflxq(i) = hflx(i) / hffac(i) endif ! call stability(z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & ! inputs From 852475b54d8be49aaeae7f59544434fb098dc96a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 10 Jun 2021 08:13:44 -0600 Subject: [PATCH 138/165] Add support for subcycling to Thompson MP, remove SIONLIB code (#676) * Add subcycling capability for Thompson MP (skip unnecessary checks/computations); remove SIONlib code for reading/writing Thompson tables * Bugfix in physics/module_mp_thompson.F90: need to test for presence of optional argument vt_dbz_wt --- physics/module_mp_thompson.F90 | 550 +++++++-------------------------- physics/mp_thompson.F90 | 86 ++++-- physics/mp_thompson.meta | 34 +- 3 files changed, 209 insertions(+), 461 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index dfe31f375..1a038ca72 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -63,7 +63,7 @@ MODULE module_mp_thompson USE module_mp_radar -#if !defined(SION) && defined(MPI) +#ifdef MPI use mpi #endif @@ -421,8 +421,7 @@ MODULE module_mp_thompson !..MPI communicator INTEGER:: mpi_communicator -!..If SIONlib isn't used, write Thompson tables with master MPI task -!.. after computing them in thompson_init +!..Write tables with master MPI task after computing them in thompson_init LOGICAL:: thompson_table_writer !+---+ @@ -453,12 +452,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & INTEGER:: i, j, k, l, m, n LOGICAL:: micro_init real :: stime, etime -#ifdef SION - INTEGER :: ierr - LOGICAL :: precomputed_tables -#else LOGICAL, PARAMETER :: precomputed_tables = .FALSE. -#endif ! Set module variable is_aerosol_aware is_aerosol_aware = is_aerosol_aware_in @@ -766,18 +760,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & ! Assign mpicomm to module variable mpi_communicator = mpicomm -#ifdef SION - call cpu_time(stime) - call readwrite_tables(thomp_table_file, "read", mpicomm, mpirank, mpiroot, ierr) - call cpu_time(etime) - if (ierr==0) then - precomputed_tables = .true. - if (mpirank==mpiroot) print '("Reading and broadcasting precomputed Thompson tables took ",f10.3," seconds.")', etime-stime - else - precomputed_tables = .false. - if (mpirank==mpiroot) write(0,*) "An error occurred reading Thompson tables from disk, recalculate" - end if -#endif + ! Standard tables are only written by master MPI task; ! (physics init cannot be called by multiple threads, ! hence no need to test for a specific thread number) @@ -899,9 +882,6 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & !> - 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 - ! 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 if (mpirank==mpiroot) write(0,*) ' calling table_ccnAct routine' call table_ccnAct(errmsg,errflg) if (.not. errflg==0) return @@ -971,17 +951,6 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & call cpu_time(etime) if (mpirank==mpiroot) print '("Calculating Thompson tables part 2 took ",f10.3," seconds.")', etime-stime -#ifdef SION - call cpu_time(stime) - call readwrite_tables(thomp_table_file, "write", mpicomm, mpirank, mpiroot, ierr) - if (ierr/=0) then - write(0,*) "An error occurred writing Thompson tables to disk" - stop 1 - end if - call cpu_time(etime) - if (mpirank==mpiroot) print '("Writing Thompson tables took ",f10.3," seconds.")', etime-stime -#endif - end if precomputed_tables_2 endif if_not_iiwarm @@ -1018,7 +987,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims - errmsg, errflg, reset) + reset_dBZ, istep, nsteps, & + errmsg, errflg) implicit none @@ -1058,9 +1028,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & refl_10cm REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & vt_dbz_wt - LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + LOGICAL, INTENT(IN) :: first_time_step REAL, INTENT(IN):: dt_in - LOGICAL, INTENT (IN) :: reset + ! To support subcycling: current step and maximum number of steps + INTEGER, INTENT (IN) :: istep, nsteps + LOGICAL, INTENT (IN) :: reset_dBZ !..Local variables REAL, DIMENSION(kts:kte):: & @@ -1093,63 +1065,66 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & if (present(errmsg)) errmsg = '' if (present(errflg)) errflg = 0 - ! DH* 2020-06-05: The stochastic perturbations code was retrofitted - ! from a newer version of the Thompson MP scheme, but it has not been - ! tested yet. - if (rand_perturb_on .ne. 0) then - errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & - 'has not been tested yet with this version of the Thompson scheme' - errflg = 1 - return - end if - ! Activate this code when removing the guard above - !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then - ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & - ! 'but optional argument rand_pert is not present' - ! errflg = 1 - ! return - !end if - ! *DH 2020-06-05 - - if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & - (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then - if (present(errmsg)) then - write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - else - write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - end if - if (present(errflg)) then - errflg = 1 - return - else - stop + ! No need to test for every subcycling step + test_only_once: if (first_time_step .and. istep==1) then + ! DH* 2020-06-05: The stochastic perturbations code was retrofitted + ! from a newer version of the Thompson MP scheme, but it has not been + ! tested yet. + if (rand_perturb_on .ne. 0) then + errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & + 'has not been tested yet with this version of the Thompson scheme' + errflg = 1 + return end if - end if - - if (is_aerosol_aware .and. (.not.present(nc) .or. & - .not.present(nwfa) .or. & - .not.present(nifa) .or. & - .not.present(nwfa2d) .or. & - .not.present(nifa2d) )) then - if (present(errmsg)) then - write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' - else - write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' + ! Activate this code when removing the guard above + !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then + ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & + ! 'but optional argument rand_pert is not present' + ! errflg = 1 + ! return + !end if + ! *DH 2020-06-05 + + if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & + (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then + if (present(errmsg)) then + write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + else + write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + end if + if (present(errflg)) then + errflg = 1 + return + else + stop + end if end if - if (present(errflg)) then - errflg = 1 - return - else - stop + + if (is_aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) .or. & + .not.present(nwfa2d) .or. & + .not.present(nifa2d) )) then + if (present(errmsg)) then + write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + else + write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + end if + if (present(errflg)) then + errflg = 1 + return + else + stop + end if + else if (.not.is_aerosol_aware .and. (present(nwfa) .or. & + present(nifa) .or. & + present(nwfa2d) .or. & + present(nifa2d) )) then + write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware is FALSE' end if - else if (.not.is_aerosol_aware .and. (present(nwfa) .or. & - present(nifa) .or. & - present(nwfa2d) .or. & - present(nifa2d) )) then - write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware is FALSE' - end if + end if test_only_once !+---+ i_start = its @@ -1421,49 +1396,54 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif enddo + ! Diagnostic calculations only for last step + ! if Thompson MP is called multiple times + last_step_only: IF (istep == nsteps) THEN + !> - Call calc_refl10cm() - IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then + diagflag_present: IF ( PRESENT (diagflag) ) THEN + if (diagflag .and. do_radar_ref == 1) then ! - ! Only set melti to true at the output times - if (reset) then + ! Only set melti to true at the output times + if (reset_dBZ) then melti=.true. - else + else melti=.false. - endif + endif ! - if (present(vt_dbz_wt) .and. present(first_time_step)) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti, vt_dbz_wt(i,:,j), & - first_time_step) - else - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti) - end if - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - endif - ENDIF + if (present(vt_dbz_wt)) then + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti, vt_dbz_wt(i,:,j), & + first_time_step) + else + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti) + end if + do k = kts, kte + refl_10cm(i,k,j) = MAX(-35., dBZ(k)) + enddo + endif + ENDIF diagflag_present - IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN - do k = kts, kte - re_qc1d(k) = re_qc_min - re_qi1d(k) = re_qi_min - re_qs1d(k) = re_qs_min - enddo + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + do k = kts, kte + re_qc1d(k) = re_qc_min + re_qi1d(k) = re_qi_min + re_qs1d(k) = re_qs_min + enddo !> - Call calc_effectrad() - call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & - re_qc1d, re_qi1d, re_qs1d, kts, kte) - do k = kts, kte - re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) - re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) - re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) - enddo - ENDIF + call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + re_qc1d, re_qi1d, re_qs1d, kts, kte) + do k = kts, kte + re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) + re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) + re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) + enddo + ENDIF + ENDIF last_step_only enddo i_loop enddo j_loop @@ -3853,10 +3833,10 @@ subroutine qr_acr_qg ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing qr_acr_qg" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing qr_acr_qg" + endif do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & @@ -4035,10 +4015,10 @@ subroutine qr_acr_qs ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing qr_acr_qs" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing qr_acr_qs" + endif do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & @@ -4290,10 +4270,10 @@ subroutine freezeH2O(threads) ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing freezeH2O" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing freezeH2O" + endif orho_w = 1./rho_w @@ -5613,300 +5593,6 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & end subroutine calc_refl10cm ! - -#ifdef SION -!>\ingroup aathompson - subroutine readwrite_tables(filename, mode, mpicomm, mpirank, mpiroot, ierr) - -#ifdef MPI - use mpi -#endif - use sion_f90 - - implicit none - - ! Interface variables - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: mode - integer, intent(in) :: mpicomm - integer, intent(in) :: mpirank - integer, intent(in) :: mpiroot - integer, intent(out) :: ierr - -#ifdef MPI - ! MPI variables - integer :: mpierr -#endif - - ! SIONlib variables - integer :: SIONLIB_fsblksize - integer :: SIONLIB_numfiles - character*2 :: SIONLIB_filemode - ! - integer :: nprocs - integer, dimension(:), allocatable :: procs - integer*8, dimension(:), allocatable :: chunksizes - ! - integer*8 :: brw - integer :: sid - integer :: f_endian, s_endian - logical :: exists - integer*8 :: tables_size - real*8 :: checksum - - integer :: i - - continue - - ierr = 0 - - ! Test if SIONlib file containing pre-computed tables exists - inquire(file=trim(filename), exist=exists) - if (trim(mode)=="read") then - SIONLIB_filemode = "rb" - if (.not.exists) then - if (mpirank==mpiroot) write(0,*) "SIONlib file " // trim(filename) // & - " with precomputed Thompson MP tables not found" - ierr = 1 - return - end if - else if (trim(mode)=="write") then - SIONLIB_filemode = "wb" - SIONLIB_numfiles = 1 - if (exists) then - if (mpirank==mpiroot) write(0,*) "SIONlib file " // trim(filename) // & - " with precomputed Thompson MP tables already exists" - ierr = 1 - return - end if - end if - -#ifdef MPI - ! To avoid that MPI master task creates the file before - ! other tasks pass the inquire test above - call MPI_BARRIER(mpicomm, mpierr) -#endif - - mpi_master_io_only: if (mpirank==mpiroot) then - tables_size = sizeof(tcg_racg) - tables_size = tables_size + sizeof(tmr_racg) - tables_size = tables_size + sizeof(tcr_gacr) - tables_size = tables_size + sizeof(tmg_gacr) - tables_size = tables_size + sizeof(tnr_racg) - tables_size = tables_size + sizeof(tnr_gacr) - tables_size = tables_size + sizeof(tcs_racs1) - tables_size = tables_size + sizeof(tmr_racs1) - tables_size = tables_size + sizeof(tcs_racs2) - tables_size = tables_size + sizeof(tmr_racs2) - tables_size = tables_size + sizeof(tcr_sacr1) - tables_size = tables_size + sizeof(tms_sacr1) - tables_size = tables_size + sizeof(tcr_sacr2) - tables_size = tables_size + sizeof(tms_sacr2) - tables_size = tables_size + sizeof(tnr_racs1) - tables_size = tables_size + sizeof(tnr_racs2) - tables_size = tables_size + sizeof(tnr_sacr1) - tables_size = tables_size + sizeof(tnr_sacr2) - tables_size = tables_size + sizeof(tpi_qcfz) - tables_size = tables_size + sizeof(tni_qcfz) - tables_size = tables_size + sizeof(tpi_qrfz) - tables_size = tables_size + sizeof(tpg_qrfz) - tables_size = tables_size + sizeof(tni_qrfz) - tables_size = tables_size + sizeof(tnr_qrfz) - tables_size = tables_size + sizeof(tps_iaus) - tables_size = tables_size + sizeof(tni_iaus) - tables_size = tables_size + sizeof(tpi_ide) - tables_size = tables_size + sizeof(t_Efrw) - tables_size = tables_size + sizeof(t_Efsw) - tables_size = tables_size + sizeof(tnr_rev) - tables_size = tables_size + sizeof(tpc_wev) - tables_size = tables_size + sizeof(tnc_wev) - tables_size = tables_size + sizeof(tnccn_act) - - ! Autodetect SIONlib filesystem block size - SIONLIB_fsblksize = -1 - - nprocs = 1 - allocate (procs(1:nprocs)) - allocate (chunksizes(1:nprocs)) - do i=1,nprocs - procs(i) = i - chunksizes(i) = sizeof(checksum) + tables_size - end do - - write(0,'(a)') "Opening file " // trim(filename) - call fsion_open(trim(filename), SIONLIB_filemode, nprocs, SIONLIB_numfiles, chunksizes(1), SIONLIB_fsblksize, procs(1), sid) - if (sid<0) write(0,'(a)') "Error opening " // trim(filename) // " in " // trim(mode) // " mode" - - call fsion_seek(sid, mpirank, SION_CURRENT_BLK, SION_CURRENT_POS, ierr) - ! fsion_seek returns ierr=1 if cursor could be positioned as requested and 0 otherwise - if (ierr==1) ierr=0 - - if (trim(mode)=="read") then - ! Check that file endianness is identical to system endianness - call fsion_get_file_endianness(sid, f_endian) - call fsion_get_endianess(s_endian) - if (f_endian .ne. s_endian) then - write(0,'(a)') "Error, endianness of SIONlib file " // trim(filename) // " differs " // & - "from filesystem endianness; please delete file and recalculate tables!" - ierr = 1 - end if - if (ierr==0) then - ! Read checksum - call fsion_read(checksum, int(kind(checksum),8), int(1,8), sid, brw) - ! Read arrays tcg_racg through tnccn_act - call fsion_read(tcg_racg(1,1,1,1), int(kind(tcg_racg(1,1,1,1)),8), int(size(tcg_racg),8), sid, brw) - call fsion_read(tmr_racg(1,1,1,1), int(kind(tmr_racg(1,1,1,1)),8), int(size(tmr_racg),8), sid, brw) - call fsion_read(tcr_gacr(1,1,1,1), int(kind(tcr_gacr(1,1,1,1)),8), int(size(tcr_gacr),8), sid, brw) - call fsion_read(tmg_gacr(1,1,1,1), int(kind(tmg_gacr(1,1,1,1)),8), int(size(tmg_gacr),8), sid, brw) - call fsion_read(tnr_racg(1,1,1,1), int(kind(tnr_racg(1,1,1,1)),8), int(size(tnr_racg),8), sid, brw) - call fsion_read(tnr_gacr(1,1,1,1), int(kind(tnr_gacr(1,1,1,1)),8), int(size(tnr_gacr),8), sid, brw) - call fsion_read(tcs_racs1(1,1,1,1), int(kind(tcs_racs1(1,1,1,1)),8), int(size(tcs_racs1),8), sid, brw) - call fsion_read(tmr_racs1(1,1,1,1), int(kind(tmr_racs1(1,1,1,1)),8), int(size(tmr_racs1),8), sid, brw) - call fsion_read(tcs_racs2(1,1,1,1), int(kind(tcs_racs2(1,1,1,1)),8), int(size(tcs_racs2),8), sid, brw) - call fsion_read(tmr_racs2(1,1,1,1), int(kind(tmr_racs2(1,1,1,1)),8), int(size(tmr_racs2),8), sid, brw) - call fsion_read(tcr_sacr1(1,1,1,1), int(kind(tcr_sacr1(1,1,1,1)),8), int(size(tcr_sacr1),8), sid, brw) - call fsion_read(tms_sacr1(1,1,1,1), int(kind(tms_sacr1(1,1,1,1)),8), int(size(tms_sacr1),8), sid, brw) - call fsion_read(tcr_sacr2(1,1,1,1), int(kind(tcr_sacr2(1,1,1,1)),8), int(size(tcr_sacr2),8), sid, brw) - call fsion_read(tms_sacr2(1,1,1,1), int(kind(tms_sacr2(1,1,1,1)),8), int(size(tms_sacr2),8), sid, brw) - call fsion_read(tnr_racs1(1,1,1,1), int(kind(tnr_racs1(1,1,1,1)),8), int(size(tnr_racs1),8), sid, brw) - call fsion_read(tnr_racs2(1,1,1,1), int(kind(tnr_racs2(1,1,1,1)),8), int(size(tnr_racs2),8), sid, brw) - call fsion_read(tnr_sacr1(1,1,1,1), int(kind(tnr_sacr1(1,1,1,1)),8), int(size(tnr_sacr1),8), sid, brw) - call fsion_read(tnr_sacr2(1,1,1,1), int(kind(tnr_sacr2(1,1,1,1)),8), int(size(tnr_sacr2),8), sid, brw) - call fsion_read(tpi_qcfz(1,1,1,1), int(kind(tpi_qcfz(1,1,1,1)),8), int(size(tpi_qcfz),8), sid, brw) - call fsion_read(tni_qcfz(1,1,1,1), int(kind(tni_qcfz(1,1,1,1)),8), int(size(tni_qcfz),8), sid, brw) - call fsion_read(tpi_qrfz(1,1,1,1), int(kind(tpi_qrfz(1,1,1,1)),8), int(size(tpi_qrfz),8), sid, brw) - call fsion_read(tpg_qrfz(1,1,1,1), int(kind(tpg_qrfz(1,1,1,1)),8), int(size(tpg_qrfz),8), sid, brw) - call fsion_read(tni_qrfz(1,1,1,1), int(kind(tni_qrfz(1,1,1,1)),8), int(size(tni_qrfz),8), sid, brw) - call fsion_read(tnr_qrfz(1,1,1,1), int(kind(tnr_qrfz(1,1,1,1)),8), int(size(tnr_qrfz),8), sid, brw) - call fsion_read(tps_iaus(1,1), int(kind(tps_iaus(1,1)),8), int(size(tps_iaus),8), sid, brw) - call fsion_read(tni_iaus(1,1), int(kind(tni_iaus(1,1)),8), int(size(tni_iaus),8), sid, brw) - call fsion_read(tpi_ide(1,1), int(kind(tpi_ide(1,1)),8), int(size(tpi_ide),8), sid, brw) - call fsion_read(t_Efrw(1,1), int(kind(t_Efrw(1,1)),8), int(size(t_Efrw),8), sid, brw) - call fsion_read(t_Efsw(1,1), int(kind(t_Efsw(1,1)),8), int(size(t_Efsw),8), sid, brw) - call fsion_read(tnr_rev(1,1,1), int(kind(tnr_rev(1,1,1)),8), int(size(tnr_rev),8), sid, brw) - call fsion_read(tpc_wev(1,1,1), int(kind(tpc_wev(1,1,1)),8), int(size(tpc_wev),8), sid, brw) - call fsion_read(tnc_wev(1,1,1), int(kind(tnc_wev (1,1,1)),8), int(size(tnc_wev),8), sid, brw) - call fsion_read(tnccn_act(1,1,1,1,1), int(kind(tnccn_act(1,1,1,1,1)),8), int(size(tnccn_act),8), sid, brw) - else - ! Wrong endianness (ierr/=0) will force checksum match to fail - checksum = -1 - end if - else if (trim(mode)=="write") then - ! Calculate and write checksum - checksum = calculate_checksum() - call fsion_write(checksum, int(kind(checksum),8), int(1,8), sid, brw) - ! Write arrays tcg_racg through tnccn_act - call fsion_write(tcg_racg(1,1,1,1), int(kind(tcg_racg(1,1,1,1)),8), int(size(tcg_racg),8), sid, brw) - call fsion_write(tmr_racg(1,1,1,1), int(kind(tmr_racg(1,1,1,1)),8), int(size(tmr_racg),8), sid, brw) - call fsion_write(tcr_gacr(1,1,1,1), int(kind(tcr_gacr(1,1,1,1)),8), int(size(tcr_gacr),8), sid, brw) - call fsion_write(tmg_gacr(1,1,1,1), int(kind(tmg_gacr(1,1,1,1)),8), int(size(tmg_gacr),8), sid, brw) - call fsion_write(tnr_racg(1,1,1,1), int(kind(tnr_racg(1,1,1,1)),8), int(size(tnr_racg),8), sid, brw) - call fsion_write(tnr_gacr(1,1,1,1), int(kind(tnr_gacr(1,1,1,1)),8), int(size(tnr_gacr),8), sid, brw) - call fsion_write(tcs_racs1(1,1,1,1), int(kind(tcs_racs1(1,1,1,1)),8), int(size(tcs_racs1),8), sid, brw) - call fsion_write(tmr_racs1(1,1,1,1), int(kind(tmr_racs1(1,1,1,1)),8), int(size(tmr_racs1),8), sid, brw) - call fsion_write(tcs_racs2(1,1,1,1), int(kind(tcs_racs2(1,1,1,1)),8), int(size(tcs_racs2),8), sid, brw) - call fsion_write(tmr_racs2(1,1,1,1), int(kind(tmr_racs2(1,1,1,1)),8), int(size(tmr_racs2),8), sid, brw) - call fsion_write(tcr_sacr1(1,1,1,1), int(kind(tcr_sacr1(1,1,1,1)),8), int(size(tcr_sacr1),8), sid, brw) - call fsion_write(tms_sacr1(1,1,1,1), int(kind(tms_sacr1(1,1,1,1)),8), int(size(tms_sacr1),8), sid, brw) - call fsion_write(tcr_sacr2(1,1,1,1), int(kind(tcr_sacr2(1,1,1,1)),8), int(size(tcr_sacr2),8), sid, brw) - call fsion_write(tms_sacr2(1,1,1,1), int(kind(tms_sacr2(1,1,1,1)),8), int(size(tms_sacr2),8), sid, brw) - call fsion_write(tnr_racs1(1,1,1,1), int(kind(tnr_racs1(1,1,1,1)),8), int(size(tnr_racs1),8), sid, brw) - call fsion_write(tnr_racs2(1,1,1,1), int(kind(tnr_racs2(1,1,1,1)),8), int(size(tnr_racs2),8), sid, brw) - call fsion_write(tnr_sacr1(1,1,1,1), int(kind(tnr_sacr1(1,1,1,1)),8), int(size(tnr_sacr1),8), sid, brw) - call fsion_write(tnr_sacr2(1,1,1,1), int(kind(tnr_sacr2(1,1,1,1)),8), int(size(tnr_sacr2),8), sid, brw) - call fsion_write(tpi_qcfz(1,1,1,1), int(kind(tpi_qcfz(1,1,1,1)),8), int(size(tpi_qcfz),8), sid, brw) - call fsion_write(tni_qcfz(1,1,1,1), int(kind(tni_qcfz(1,1,1,1)),8), int(size(tni_qcfz),8), sid, brw) - call fsion_write(tpi_qrfz(1,1,1,1), int(kind(tpi_qrfz(1,1,1,1)),8), int(size(tpi_qrfz),8), sid, brw) - call fsion_write(tpg_qrfz(1,1,1,1), int(kind(tpg_qrfz(1,1,1,1)),8), int(size(tpg_qrfz),8), sid, brw) - call fsion_write(tni_qrfz(1,1,1,1), int(kind(tni_qrfz(1,1,1,1)),8), int(size(tni_qrfz),8), sid, brw) - call fsion_write(tnr_qrfz(1,1,1,1), int(kind(tnr_qrfz(1,1,1,1)),8), int(size(tnr_qrfz),8), sid, brw) - call fsion_write(tps_iaus(1,1), int(kind(tps_iaus(1,1)),8), int(size(tps_iaus),8), sid, brw) - call fsion_write(tni_iaus(1,1), int(kind(tni_iaus(1,1)),8), int(size(tni_iaus),8), sid, brw) - call fsion_write(tpi_ide(1,1), int(kind(tpi_ide(1,1)),8), int(size(tpi_ide),8), sid, brw) - call fsion_write(t_Efrw(1,1), int(kind(t_Efrw(1,1)),8), int(size(t_Efrw),8), sid, brw) - call fsion_write(t_Efsw(1,1), int(kind(t_Efsw(1,1)),8), int(size(t_Efsw),8), sid, brw) - call fsion_write(tnr_rev(1,1,1), int(kind(tnr_rev(1,1,1)),8), int(size(tnr_rev),8), sid, brw) - call fsion_write(tpc_wev(1,1,1), int(kind(tpc_wev(1,1,1)),8), int(size(tpc_wev),8), sid, brw) - call fsion_write(tnc_wev(1,1,1), int(kind(tnc_wev (1,1,1)),8), int(size(tnc_wev),8), sid, brw) - call fsion_write(tnccn_act(1,1,1,1,1), int(kind(tnccn_act(1,1,1,1,1)),8), int(size(tnccn_act),8), sid, brw) - end if - - write(0,'(a)') "Closing file " // trim(filename) - call fsion_close(sid, ierr) - - ierr = 0 - ! Test if checksum matches, this fails if wrong endianness (checksum=-1, see above) - if (trim(mode)=="read" .and. checksum/=calculate_checksum()) then - write(0,'(2(a,e20.9))') "Checksum mismatch, expected", calculate_checksum(), " but got", checksum - call system('rm -f ' // trim(filename)) - ierr = 1 - end if - - deallocate (procs) - deallocate (chunksizes) - - else - - ierr = 0 - - end if mpi_master_io_only - -#ifdef MPI - if (trim(mode)=="read") then - ! After reading the tables, broadcast the information to all MPI tasks. - ! First, broadcast the current error code from MPI master (0 = success) - call MPI_BCAST(ierr, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - if (ierr/=0) return - call MPI_BCAST(tcg_racg, size(tcg_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racg, size(tmr_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_gacr, size(tcr_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmg_gacr, size(tmg_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racg, size(tnr_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_gacr, size(tnr_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcs_racs1, size(tcs_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racs1, size(tmr_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcs_racs2, size(tcs_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racs2, size(tmr_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_sacr1, size(tcr_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tms_sacr1, size(tms_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_sacr2, size(tcr_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tms_sacr2, size(tms_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racs1, size(tnr_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racs2, size(tnr_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_sacr1, size(tnr_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_sacr2, size(tnr_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_qcfz, size(tpi_qcfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_qcfz, size(tni_qcfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_qrfz, size(tpi_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpg_qrfz, size(tpg_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_qrfz, size(tni_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_qrfz, size(tnr_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tps_iaus, size(tps_iaus), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_iaus, size(tni_iaus), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_ide, size(tpi_ide), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(t_Efrw, size(t_Efrw), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(t_Efsw, size(t_Efsw), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_rev, size(tnr_rev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpc_wev, size(tpc_wev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnc_wev, size(tnc_wev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnccn_act, size(tnccn_act), MPI_REAL, mpiroot, mpicomm, mpierr) - else if (trim(mode)=="write") then - call MPI_BARRIER(mpicomm, mpierr) - end if -#endif - - return - - contains - - function calculate_checksum() result(checksum) - real*8 :: checksum - checksum = real(tables_size,8)*sum(tcg_racg) - end function calculate_checksum - - end subroutine readwrite_tables -#endif - !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1ad4b2d4b..1d235c3e6 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -99,14 +99,6 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & if (is_initialized) return - ! DH* temporary - if (mpirank==mpiroot) then - write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING --- the CCPP Thompson MP scheme is currently under development, use at your own risk --- WARNING ---' - write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - end if - ! *DH temporary - ! Consistency checks if (imp_physics/=imp_physics_thompson) then write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from Thompson MP" @@ -328,12 +320,13 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & spechum, qc, qr, qi, qs, qg, ni, nr, & is_aerosol_aware, nc, nwfa, nifa, & nwfa2d, nifa2d, & - tgrs, prsl, phii, omega, dtp, & + tgrs, prsl, phii, omega, & + dtp, first_time_step, istep, nsteps, & prcp, rain, graupel, ice, snow, sr, & - refl_10cm, reset, do_radar_ref, & + refl_10cm, reset_dBZ, do_radar_ref, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - errmsg, errflg) + blkno, errmsg, errflg) implicit none @@ -356,7 +349,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(inout) :: ni(:,:) real(kind_phys), intent(inout) :: nr(:,:) ! Aerosols - logical, intent(in) :: is_aerosol_aware, reset + logical, intent(in) :: is_aerosol_aware, reset_dBZ ! The following arrays are not allocated if is_aerosol_aware is false real(kind_phys), optional, intent(inout) :: nc(:,:) real(kind_phys), optional, intent(inout) :: nwfa(:,:) @@ -369,6 +362,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(in ) :: phii(:,:) real(kind_phys), intent(in ) :: omega(:,:) real(kind_phys), intent(in ) :: dtp + logical, intent(in ) :: first_time_step + integer, intent(in ) :: istep, nsteps ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip real(kind_phys), intent(inout) :: prcp(:) real(kind_phys), intent(inout) :: rain(:) @@ -383,7 +378,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent( out) :: re_cloud(:,:) real(kind_phys), optional, intent( out) :: re_ice(:,:) real(kind_phys), optional, intent( out) :: re_snow(:,:) - ! MPI information + ! MPI and block information + integer, intent(in) :: blkno integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot @@ -393,6 +389,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! Local variables + ! Reduced time step if subcycling is used + real(kind_phys) :: dtstep ! Air density real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 ! Water vapor mixing ratio (instead of specific humidity) @@ -439,23 +437,39 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & return end if - if (is_aerosol_aware .and. .not. (present(nc) .and. & - present(nwfa) .and. & - present(nifa) .and. & - present(nwfa2d) .and. & - present(nifa2d) )) then - write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & - ' aerosol-aware microphysics require all of the', & - ' following optional arguments:', & - ' nc, nwfa, nifa, nwfa2d, nifa2d' - errflg = 1 - return + ! Set reduced time step if subcycling is used + if (nsteps>1) then + dtstep = dtp/real(nsteps, kind=kind_phys) + else + dtstep = dtp + end if + if (first_time_step .and. istep==1 .and. mpirank==mpiroot .and. blkno==1) then + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & + ' with an effective time step of ', dtstep, ' seconds' + end if + + if (first_time_step .and. istep==1) then + if (is_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) .and. & + present(nwfa2d) .and. & + present(nifa2d) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & + ' aerosol-aware microphysics require all of the', & + ' following optional arguments:', & + ' nc, nwfa, nifa, nwfa2d, nifa2d' + errflg = 1 + return + end if end if !> - Convert specific humidity to water vapor mixing ratio. !> - Also, hydrometeor variables are mass or number mixing ratio !> - either kg of species per kg of dry air, or per kg of (dry + vapor). + ! DH* - do this only if istep == 1? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. qv = spechum/(1.0_kind_phys-spechum) if (convert_dry_rho) then @@ -473,6 +487,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & nifa = nifa/(1.0_kind_phys-spechum) end if end if + ! *DH !> - Density of air in kg m-3 rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) @@ -566,7 +581,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -585,7 +601,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) end if else if (do_effective_radii) then @@ -606,7 +623,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -624,11 +642,16 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) end if end if if (errflg/=0) return + ! DH* - do this only if istep == nsteps? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. + !> - Convert water vapor mixing ratio back to specific humidity spechum = qv/(1.0_kind_phys+qv) @@ -647,6 +670,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & nifa = nifa/(1.0_kind_phys+qv) end if end if + ! *DH !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in Thompson MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) @@ -656,6 +680,12 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + ! Recompute sr at last subcycling step + if (nsteps>1 .and. istep == nsteps) then + ! Unlike inside mp_gt_driver, rain does not contain frozen precip + sr = (snow + graupel + ice)/(rain + snow + graupel + ice +1.e-12) + end if + end subroutine mp_thompson_run !>@} diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 237890024..573bab6c8 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -545,6 +545,30 @@ kind = kind_phys intent = in optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[istep] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[nsteps] + standard_name = ccpp_loop_extent + long_name = loop extent for subcycling loops in CCPP + units = count + dimensions = () + type = integer + intent = in + optional = F [prcp] standard_name = lwe_thickness_of_explicit_precipitation_amount long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep @@ -608,7 +632,7 @@ kind = kind_phys intent = out optional = F -[reset] +[reset_dBZ] standard_name = flag_for_resetting_radar_reflectivity_calculation long_name = flag for resetting radar reflectivity calculation units = flag @@ -675,6 +699,14 @@ type = integer intent = in optional = F +[blkno] + standard_name = ccpp_block_number + long_name = number of block for explicit data blocking in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6910dde33c12192f1c9b884b88ccf1b3bff4c16c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 15 Jun 2021 13:50:29 +0000 Subject: [PATCH 139/165] adding a blank space --- physics/GFS_surface_composites.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 4671d9642..06fd5f4b9 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -440,7 +440,7 @@ subroutine GFS_surface_composites_post_run ( stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_lnd, weasd_ice, & - snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & + snowd_lnd, snowd_ice, tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & From e4528fbf39f49ed43faffc42b597622fb78bf724 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Sat, 19 Jun 2021 00:35:58 +0000 Subject: [PATCH 140/165] a minor change in RAS --- physics/rascnv.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index ee58baecd..e48dfccee 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -681,7 +681,8 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & if (advups) then ! For first order upstream for updraft alfint(:,:) = one elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = one +! alfint(:,:) = one + alfint(:,:) = half l = krmin lm1 = l - 1 dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & From 9cdc2b525083d8c4422ce4e861f3eb85866d863c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 21 Jun 2021 19:24:41 +0000 Subject: [PATCH 141/165] reverting lake to use_flake in sfc_ocean --- physics/sfc_ocean.F | 8 ++++---- physics/sfc_ocean.meta | 6 +++--- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index e5f8f8e68..67a6df04f 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -27,7 +27,7 @@ subroutine sfc_ocean_run & !................................... ! --- inputs: & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & - & tskin, cm, ch, prsl1, prslki, wet, lake, wind, &, ! --- inputs + & tskin, cm, ch, prsl1, prslki, wet, use_flake, wind, &, ! --- inputs & flag_iter, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -42,7 +42,7 @@ subroutine sfc_ocean_run & ! inputs: ! ! ( im, ps, t1, q1, tskin, cm, ch, ! !! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! -! prsl1, prslki, wet, lake, wind, flag_iter, ! +! prsl1, prslki, wet, use_flake, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! ! ! @@ -102,7 +102,7 @@ subroutine sfc_ocean_run & real (kind=kind_phys), dimension(:), intent(in) :: ps, & & t1, q1, tskin, cm, ch, prsl1, prslki, wind - logical, dimension(:), intent(in) :: flag_iter, wet, lake + logical, dimension(:), intent(in) :: flag_iter, wet, use_flake ! --- outputs: real (kind=kind_phys), dimension(:), intent(inout) :: qsurf, & @@ -130,7 +130,7 @@ subroutine sfc_ocean_run & ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface - if (wet(i) .and. flag_iter(i) .and. .not. lake(i)) then + if (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) then q0 = max( q1(i), qmin ) rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 6fdfa0555..844eaed88 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -131,9 +131,9 @@ type = logical intent = in optional = F -[lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction +[use_flake] + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical From 0e3bb76df4c61d947e4227b4c230510589cb6cac Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 22 Jun 2021 08:31:06 -0600 Subject: [PATCH 142/165] Update Thompson extended diagnostics code --- physics/module_mp_thompson.F90 | 453 +++++++++++++++++++++------------ physics/mp_thompson.F90 | 335 +++++++++++++++++------- physics/mp_thompson.meta | 47 +++- 3 files changed, 566 insertions(+), 269 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index cd4d84d8d..0996349a4 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1,3 +1,4 @@ + !>\file module_mp_thompson.F90 !! This file contains the entity of GSD Thompson MP scheme. @@ -988,7 +989,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte, & ! tile dims reset_dBZ, istep, nsteps, & - errmsg, errflg, vts1, prw_vcdc, & + errmsg, errflg, & + ! Extended diagnostics, array pointers + ! only associated if ext_diag flag is .true. + ext_diag, vts1, prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & tpri_ide_s, tprs_ide_d, tprs_ide_s, & tprs_sde_d, tprs_sde_s, tprg_gde_d, & @@ -1011,21 +1015,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & its,ite, jts,jte, kts,kte REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & qv, qc, qr, qi, qs, qg, ni, nr - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - vts1, prw_vcdc, & - prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide_d, tprs_ide_s, & - tprs_sde_d, tprs_sde_s, tprg_gde_d, & - tprg_gde_s, tpri_iha, tpri_wfz, & - tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs_s, tprs_rcs_r, & - tprr_rci, tprg_rcg_g, tprg_rcg_r, & - tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg_r, tprr_rcg_g, & - tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & - txrc, tten3, qvten3, qrten3, qsten3, & - qgten3, qiten3, niten3, nrten3, ncten3, & - qcten3 REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & tt, th REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(IN):: & @@ -1061,27 +1050,45 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! To support subcycling: current step and maximum number of steps INTEGER, INTENT (IN) :: istep, nsteps LOGICAL, INTENT (IN) :: reset_dBZ + ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. + LOGICAL, INTENT (IN) :: ext_diag + REAL, DIMENSION(:,:,:), INTENT(INOUT):: & + vts1, prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide_d, tprs_ide_s, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs_s, tprs_rcs_r, & + tprr_rci, tprg_rcg_g, tprg_rcg_r, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg_r, tprr_rcg_g, & + tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & + txrc, tten3, qvten3, qrten3, qsten3, & + qgten3, qiten3, niten3, nrten3, ncten3, & + qcten3 !..Local variables REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ - REAL, DIMENSION(kts:kte):: & - vtsk1, prw_vcdc1, & - prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & - tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & - tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & - tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & - tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & - tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& - txrc1, tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, & - qcten1 +!..Extended diagnostics, single column arrays + REAL, DIMENSION(:), ALLOCATABLE:: & + vtsk1, prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & + tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & + tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, & + qcten1 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) @@ -1170,6 +1177,59 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & end if end if test_only_once + allocate_extended_diagnostics: if (ext_diag) then + allocate (vtsk1(kts:kte)) + allocate (prw_vcdc1(kts:kte)) + allocate (prw_vcde1(kts:kte)) + allocate (tpri_inu1(kts:kte)) + allocate (tpri_ide1_d(kts:kte)) + allocate (tpri_ide1_s(kts:kte)) + allocate (tprs_ide1_d(kts:kte)) + allocate (tprs_ide1_s(kts:kte)) + allocate (tprs_sde1_d(kts:kte)) + allocate (tprs_sde1_s(kts:kte)) + allocate (tprg_gde1_d(kts:kte)) + allocate (tprg_gde1_s(kts:kte)) + allocate (tpri_iha1(kts:kte)) + allocate (tpri_wfz1(kts:kte)) + allocate (tpri_rfz1(kts:kte)) + allocate (tprg_rfz1(kts:kte)) + allocate (tprs_scw1(kts:kte)) + allocate (tprg_scw1,(kts:kte)) + allocate (tprg_rcs1(kts:kte)) + allocate (tprs_rcs1_s(kts:kte)) + allocate (tprs_rcs1_r(kts:kte)) + allocate (tprr_rci1(kts:kte)) + allocate (tprg_rcg1_g(kts:kte)) + allocate (tprg_rcg1_r(kts:kte)) + allocate (tprw_vcd1_c(kts:kte)) + allocate (tprw_vcd1_e(kts:kte)) + allocate (tprr_sml1(kts:kte)) + allocate (tprr_gml1(kts:kte)) + allocate (tprr_rcg1_r(kts:kte)) + allocate (tprr_rcg1_g(kts:kte)) + allocate (tprr_rcs1_r(kts:kte)) + allocate (tprr_rcs1_s(kts:kte)) + allocate (tprv_rev1(kts:kte)) + allocate (txri1,(kts:kte)) + allocate (txrc1(kts:kte)) + allocate (tten1(kts:kte)) + allocate (qvten1(kts:kte)) + allocate (qrten1(kts:kte)) + allocate (qsten1(kts:kte)) + allocate (qgten1(kts:kte)) + allocate (qiten1(kts:kte)) + allocate (niten1(kts:kte)) + allocate (nrten1(kts:kte)) + allocate (ncten1(kts:kte)) + allocate (qcten1(kts:kte)) + else + ! These must be allocated always + allocate (vtsk1(kts:kte)) + allocate (txri1(kts:kte)) + allocate (txrc1(kts:kte)) + end if allocate_extended_diagnostics + !+---+ i_start = its j_start = jts @@ -1279,52 +1339,59 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) - - vtsk1(k) = 0. - prw_vcdc1(k) = 0. - prw_vcde1(k) = 0. - tpri_inu1(k) = 0. - tpri_ide1_d(k) = 0. - tpri_ide1_s(k) = 0. - tprs_ide1_d(k) = 0. - tprs_ide1_s(k) = 0. - tprs_sde1_d(k) = 0. - tprs_sde1_s(k) = 0. - tprg_gde1_d(k) = 0. - tprg_gde1_s(k) = 0. - tpri_iha1(k) = 0. - tpri_wfz1(k) = 0. - tpri_rfz1(k) = 0. - tprg_rfz1(k) = 0. - tprg_scw1(k) = 0. - tprs_scw1(k) = 0. - tprg_rcs1(k) = 0. - tprs_rcs1_s(k) = 0. - tprs_rcs1_r(k) = 0. - tprr_rci1(k) = 0. - tprg_rcg1_g(k) = 0. - tprg_rcg1_r(k) = 0. - tprw_vcd1_c(k) = 0. - tprw_vcd1_e(k) = 0. - tprr_sml1(k) = 0. - tprr_gml1(k) = 0. - tprr_rcg1_r(k) = 0. - tprr_rcg1_g(k) = 0. - tprr_rcs1_r(k) = 0. - tprr_rcs1_s(k) = 0. - tprv_rev1(k) = 0. - txrc1(k) = 0. - txri1(k) = 0. - tten1(k) = 0. - qvten1(k) = 0. - qrten1(k) = 0. - qsten1(k) = 0. - qgten1(k) = 0. - qiten1(k) = 0. - niten1(k) = 0. - nrten1(k) = 0. - ncten1(k) = 0. - qcten1(k) = 0. + + initialize_extended_diagnostics: if (ext_diag) then + vtsk1(k) = 0. + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1_d(k) = 0. + tprs_ide1_s(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprg_scw1(k) = 0. + tprs_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1_s(k) = 0. + tprs_rcs1_r(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1_g(k) = 0. + tprg_rcg1_r(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1_r(k) = 0. + tprr_rcg1_g(k) = 0. + tprr_rcs1_r(k) = 0. + tprr_rcs1_s(k) = 0. + tprv_rev1(k) = 0. + txrc1(k) = 0. + txri1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. + else + ! These arrays are always allocated and must be initialized + vtsk1(k) = 0. + txrc1(k) = 0. + txri1(k) = 0. + endif enddo if (is_aerosol_aware) then do k = kts, kte @@ -1412,48 +1479,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg(i,k,j) = qg1d(k) ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) - vts1(i,k,j) = vtsk1(k) - prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) - prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) - tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) - tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) - tprs_ide_d(i,k,j) = tprs_ide_d(i,k,j) + tprs_ide1_d(k) - tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) - tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) - tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) - tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) - tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) - tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) - tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) - tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) - tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) - tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) - tprs_rcs_s(i,k,j) = tprs_rcs_s(i,k,j) + tprs_rcs1_s(k) - tprs_rcs_r(i,k,j) = tprs_rcs_r(i,k,j) + tprs_rcs1_r(k) - tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) - tprg_rcg_g(i,k,j) = tprg_rcg_g(i,k,j) + tprg_rcg1_g(k) - tprg_rcg_r(i,k,j) = tprg_rcg_r(i,k,j) + tprg_rcg1_r(k) - tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) - tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) - tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) - tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) - tprr_rcg_r(i,k,j) = tprr_rcg_r(i,k,j) + tprr_rcg1_r(k) - tprr_rcg_g(i,k,j) = tprr_rcg_g(i,k,j) + tprr_rcg1_g(k) - tprr_rcs_r(i,k,j) = tprr_rcs_r(i,k,j) + tprr_rcs1_r(k) - tprr_rcs_s(i,k,j) = tprr_rcs_s(i,k,j) + tprr_rcs1_s(k) - tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) - txri(i,k,j) = txri(i,k,j) + txri1(k) - txrc(i,k,j) = txrc(i,k,j) + txrc1(k) - tten3(i,k,j) = tten3(i,k,j) + tten1(k) - qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) - qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) - qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) - qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) - qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) - niten3(i,k,j) = niten3(i,k,j) + niten1(k) - nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) - ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) - qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) if (present(tt)) then; tt(i,k,j) = t1d(k) else @@ -1538,6 +1563,53 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif enddo + assign_extended_diagnostics: if (ext_diag) then + do k=kts,kte + vts1(i,k,j) = vtsk1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) + tprs_ide_d(i,k,j) = tprs_ide_d(i,k,j) + tprs_ide1_d(k) + tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) + tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs_s(i,k,j) = tprs_rcs_s(i,k,j) + tprs_rcs1_s(k) + tprs_rcs_r(i,k,j) = tprs_rcs_r(i,k,j) + tprs_rcs1_r(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg_g(i,k,j) = tprg_rcg_g(i,k,j) + tprg_rcg1_g(k) + tprg_rcg_r(i,k,j) = tprg_rcg_r(i,k,j) + tprg_rcg1_r(k) + tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) + tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg_r(i,k,j) = tprr_rcg_r(i,k,j) + tprr_rcg1_r(k) + tprr_rcg_g(i,k,j) = tprr_rcg_g(i,k,j) + tprr_rcg1_g(k) + tprr_rcs_r(i,k,j) = tprr_rcs_r(i,k,j) + tprr_rcs1_r(k) + tprr_rcs_s(i,k,j) = tprr_rcs_s(i,k,j) + tprr_rcs1_s(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + txri(i,k,j) = txri(i,k,j) + txri1(k) + txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + tten3(i,k,j) = tten3(i,k,j) + tten1(k) + qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) + qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) + qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) + qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) + qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) + niten3(i,k,j) = niten3(i,k,j) + niten1(k) + nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) + ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) + qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) + enddo + endif assign_extended_diagnostics + ! Diagnostic calculations only for last step ! if Thompson MP is called multiple times last_step_only: IF (istep == nsteps) THEN @@ -1601,6 +1673,59 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' ! END DEBUG - GT + deallocate_extended_diagnostics: if (ext_diag) then + deallocate (vtsk1) + deallocate (prw_vcdc1) + deallocate (prw_vcde1) + deallocate (tpri_inu1) + deallocate (tpri_ide1_d) + deallocate (tpri_ide1_s) + deallocate (tprs_ide1_d) + deallocate (tprs_ide1_s) + deallocate (tprs_sde1_d) + deallocate (tprs_sde1_s) + deallocate (tprg_gde1_d) + deallocate (tprg_gde1_s) + deallocate (tpri_iha1) + deallocate (tpri_wfz1) + deallocate (tpri_rfz1) + deallocate (tprg_rfz1) + deallocate (tprs_scw1) + deallocate (tprg_scw1,) + deallocate (tprg_rcs1) + deallocate (tprs_rcs1_s) + deallocate (tprs_rcs1_r) + deallocate (tprr_rci1) + deallocate (tprg_rcg1_g) + deallocate (tprg_rcg1_r) + deallocate (tprw_vcd1_c) + deallocate (tprw_vcd1_e) + deallocate (tprr_sml1) + deallocate (tprr_gml1) + deallocate (tprr_rcg1_r) + deallocate (tprr_rcg1_g) + deallocate (tprr_rcs1_r) + deallocate (tprr_rcs1_s) + deallocate (tprv_rev1) + deallocate (txri1,) + deallocate (txrc1) + deallocate (tten1) + deallocate (qvten1) + deallocate (qrten1) + deallocate (qsten1) + deallocate (qgten1) + deallocate (qiten1) + deallocate (niten1) + deallocate (nrten1) + deallocate (ncten1) + deallocate (qcten1) + else + ! These are always allocated + deallocate (vtsk1) + deallocate (txri1) + deallocate (txrc1) + end if deallocate_extended_diagnostics + END SUBROUTINE mp_gt_driver !> @} @@ -1665,24 +1790,27 @@ END SUBROUTINE thompson_finalize !! Thompson et al. (2004, 2008)\cite Thompson_2004 \cite Thompson_2008. !>\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, & - pptrain, pptsnow, pptgraul, pptice, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & + pptrain, pptsnow, pptgraul, pptice, & #if ( WRF_CHEM == 1 ) - rainprod, evapprod, & + rainprod, evapprod, & #endif - rand1, rand2, rand3, & - kts, kte, dt, ii, jj,vtsk1, prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& - tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & - tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & - tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & - tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& - txri1, txrc1, tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, qcten1) + rand1, rand2, rand3, & + kts, kte, dt, ii, jj, & + ! Extended diagnostics, most arrays only + ! allocated if ext_diag flag is .true. + ext_diag, vtsk1, prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& + tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & + tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & + tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& + txri1, txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1) #ifdef MPI use mpi #endif @@ -1697,21 +1825,23 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 - REAL, DIMENSION(kts:kte), INTENT(OUT):: & - vtsk1, prw_vcdc1, & - prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & - tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & - tprg_gde1_s, tpri_iha1, tpri_wfz1, & - tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & - tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & - tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & - tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& - txrc1, tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, & - qcten1 + ! Extended diagnostics, most arrays only allocated if ext_diag is true + LOGICAL, INTENT(IN) :: ext_diag + REAL, DIMENSION(:), INTENT(OUT):: & + vtsk1, prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & + tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & + tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + txrc1, tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, & + qcten1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod @@ -1912,7 +2042,17 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_rcd(k) = 0. pnd_scd(k) = 0. pnd_gcd(k) = 0. + enddo +#if ( WRF_CHEM == 1 ) + do k = kts, kte + rainprod(k) = 0. + evapprod(k) = 0. + enddo +#endif + !Diagnostics + if (ext_diag) then + do k = kts, kte vtsk1(k) = 0. prw_vcdc1(k) = 0. prw_vcde1(k) = 0. @@ -1958,13 +2098,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nrten1(k) = 0. ncten1(k) = 0. qcten1(k) = 0. - enddo -#if ( WRF_CHEM == 1 ) - do k = kts, kte - rainprod(k) = 0. - evapprod(k) = 0. - enddo -#endif + enddo + endif !..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. do k = kts, kte diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1a74b6758..8bdde0479 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -22,6 +22,8 @@ module mp_thompson logical :: is_initialized = .False. + integer, parameter :: ext_ndiag3d = 45 + contains !> This subroutine is a wrapper around the actual thompson_init(). @@ -36,7 +38,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & nwfa, nifa, tgrs, prsl, phil, area, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - threads, errmsg, errflg) + threads, ext_diag, ext_ndiag3d_in, & + errmsg, errflg) implicit none @@ -79,6 +82,9 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & integer, intent(in ) :: mpiroot ! Threading/blocking information integer, intent(in ) :: threads + ! Extended diagnostics + logical, intent(in ) :: ext_diag + integer, intent(in ) :: ext_ndiag3d_in ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -106,6 +112,12 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & return end if + if (ext_diag and ext_ndiag3d_in /= ext_ndiag3d) then + write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" + errflg = 1 + return + end if + ! Call Thompson init call thompson_init(is_aerosol_aware_in=is_aerosol_aware, mpicomm=mpicomm, & mpirank=mpirank, mpiroot=mpiroot, threads=threads, & @@ -326,7 +338,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & refl_10cm, reset_dBZ, do_radar_ref, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - blkno, errmsg, errflg, naux3d, aux3d) + blkno, ext_diag, diag3d, & + errmsg, errflg) implicit none @@ -383,12 +396,13 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + ! Extended diagnostic output + logical, intent(in) :: ext_diag + real(kind_phys), intent(inout) :: diag3d(:,:,:) + ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg - ! Auxillary output - integer, intent(in) :: naux3d - real(kind_phys), intent(inout) :: aux3d(:,:,:) ! Local variables @@ -428,6 +442,52 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + ! Pointer arrays for extended diagnostics + real(kind_phys), dimension(:,:), pointer :: vts1 => null() + real(kind_phys), dimension(:,:), pointer :: prw_vcdc => null() + real(kind_phys), dimension(:,:), pointer :: prw_vcde => null() + real(kind_phys), dimension(:,:), pointer :: tpri_inu => null() + real(kind_phys), dimension(:,:), pointer :: tpri_ide_d => null() + real(kind_phys), dimension(:,:), pointer :: tpri_ide_s => null() + real(kind_phys), dimension(:,:), pointer :: tprs_ide_d => null() + real(kind_phys), dimension(:,:), pointer :: tprs_ide_s => null() + real(kind_phys), dimension(:,:), pointer :: tprs_sde_d => null() + real(kind_phys), dimension(:,:), pointer :: tprs_sde_s => null() + real(kind_phys), dimension(:,:), pointer :: tprg_gde_d => null() + real(kind_phys), dimension(:,:), pointer :: tprg_gde_s => null() + real(kind_phys), dimension(:,:), pointer :: tpri_iha => null() + real(kind_phys), dimension(:,:), pointer :: tpri_wfz => null() + real(kind_phys), dimension(:,:), pointer :: tpri_rfz => null() + real(kind_phys), dimension(:,:), pointer :: tprg_rfz => null() + real(kind_phys), dimension(:,:), pointer :: tprs_scw => null() + real(kind_phys), dimension(:,:), pointer :: tprg_scw => null() + real(kind_phys), dimension(:,:), pointer :: tprg_rcs => null() + real(kind_phys), dimension(:,:), pointer :: tprs_rcs_s => null() + real(kind_phys), dimension(:,:), pointer :: tprs_rcs_r => null() + real(kind_phys), dimension(:,:), pointer :: tprr_rci => null() + real(kind_phys), dimension(:,:), pointer :: tprg_rcg_g => null() + real(kind_phys), dimension(:,:), pointer :: tprg_rcg_r => null() + real(kind_phys), dimension(:,:), pointer :: tprw_vcd_c => null() + real(kind_phys), dimension(:,:), pointer :: tprw_vcd_e => null() + real(kind_phys), dimension(:,:), pointer :: tprr_sml => null() + real(kind_phys), dimension(:,:), pointer :: tprr_gml => null() + real(kind_phys), dimension(:,:), pointer :: tprr_rcg_r => null() + real(kind_phys), dimension(:,:), pointer :: tprr_rcg_g => null() + real(kind_phys), dimension(:,:), pointer :: tprr_rcs_r => null() + real(kind_phys), dimension(:,:), pointer :: tprr_rcs_s => null() + real(kind_phys), dimension(:,:), pointer :: tprv_rev => null() + real(kind_phys), dimension(:,:), pointer :: txri => null() + real(kind_phys), dimension(:,:), pointer :: txrc => null() + real(kind_phys), dimension(:,:), pointer :: tten3 => null() + real(kind_phys), dimension(:,:), pointer :: qvten3 => null() + real(kind_phys), dimension(:,:), pointer :: qrten3 => null() + real(kind_phys), dimension(:,:), pointer :: qsten3 => null() + real(kind_phys), dimension(:,:), pointer :: qgten3 => null() + real(kind_phys), dimension(:,:), pointer :: qiten3 => null() + real(kind_phys), dimension(:,:), pointer :: niten3 => null() + real(kind_phys), dimension(:,:), pointer :: nrten3 => null() + real(kind_phys), dimension(:,:), pointer :: ncten3 => null() + real(kind_phys), dimension(:,:), pointer :: qcten3 => null() ! Initialize the CCPP error handling variables errmsg = '' @@ -563,6 +623,55 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & kme = nlev kte = nlev + ! Set pointers for extended diagnostics + set_extended_diagnostic_pointers: if (ext_diag) then + vts1 => diag3d(:,:,1) + prw_vcdc => diag3d(:,:,2) + prw_vcde => diag3d(:,:,3) + tpri_inu => diag3d(:,:,4) + tpri_ide_d => diag3d(:,:,5) + tpri_ide_s => diag3d(:,:,6) + tprs_ide_d => diag3d(:,:,7) + tprs_ide_s => diag3d(:,:,8) + tprs_sde_d => diag3d(:,:,9) + tprs_sde_s => diag3d(:,:,10) + tprg_gde_d => diag3d(:,:,11) + tprg_gde_s => diag3d(:,:,12) + tpri_iha => diag3d(:,:,13) + tpri_wfz => diag3d(:,:,14) + tpri_rfz => diag3d(:,:,15) + tprg_rfz => diag3d(:,:,16) + tprs_scw => diag3d(:,:,17) + tprg_scw => diag3d(:,:,18) + tprg_rcs => diag3d(:,:,19) + tprs_rcs_s => diag3d(:,:,20) + tprs_rcs_r => diag3d(:,:,21) + tprr_rci => diag3d(:,:,22) + tprg_rcg_g => diag3d(:,:,23) + tprg_rcg_r => diag3d(:,:,24) + tprw_vcd_c => diag3d(:,:,25) + tprw_vcd_e => diag3d(:,:,26) + tprr_sml => diag3d(:,:,27) + tprr_gml => diag3d(:,:,28) + tprr_rcg_r => diag3d(:,:,29) + tprr_rcg_g => diag3d(:,:,30) + tprr_rcs_r => diag3d(:,:,31) + tprr_rcs_s => diag3d(:,:,32) + tprv_rev => diag3d(:,:,33) + txri => diag3d(:,:,34) + txrc => diag3d(:,:,35) + tten3 => diag3d(:,:,36) + qvten3 => diag3d(:,:,37) + qrten3 => diag3d(:,:,38) + qsten3 => diag3d(:,:,39) + qgten3 => diag3d(:,:,40) + qiten3 => diag3d(:,:,41) + niten3 => diag3d(:,:,42) + nrten3 => diag3d(:,:,43) + ncten3 => diag3d(:,:,44) + qcten3 => diag3d(:,:,45) + end if set_extended_diagnostic_pointers + !> - Call mp_gt_driver() with or without aerosols if (is_aerosol_aware) then if (do_effective_radii) then @@ -586,29 +695,25 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & - tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & + tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & + tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & + tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & + tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -629,29 +734,25 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & - tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & + tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & + tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & + tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & + tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3)) end if else if (do_effective_radii) then @@ -674,29 +775,25 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & - tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & + tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & + tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & + tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & + tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -716,29 +813,25 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - vts1=aux3d(:,:,1), & - prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & - tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37), qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43), ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & + tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & + tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & + tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & + tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3)) end if end if if (errflg/=0) return @@ -781,6 +874,54 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & sr = (snow + graupel + ice)/(rain + snow + graupel + ice +1.e-12) end if + unset_extended_diagnostic_pointers: if (ext_diag) then + vts1 => null() + prw_vcdc => null() + prw_vcde => null() + tpri_inu => null() + tpri_ide_d => null() + tpri_ide_s => null() + tprs_ide_d => null() + tprs_ide_s => null() + tprs_sde_d => null() + tprs_sde_s => null() + tprg_gde_d => null() + tprg_gde_s => null() + tpri_iha => null() + tpri_wfz => null() + tpri_rfz => null() + tprg_rfz => null() + tprs_scw => null() + tprg_scw => null() + tprg_rcs => null() + tprs_rcs_s => null() + tprs_rcs_r => null() + tprr_rci => null() + tprg_rcg_g => null() + tprg_rcg_r => null() + tprw_vcd_c => null() + tprw_vcd_e => null() + tprr_sml => null() + tprr_gml => null() + tprr_rcg_r => null() + tprr_rcg_g => null() + tprr_rcs_r => null() + tprr_rcs_s => null() + tprv_rev => null() + txri => null() + txrc => null() + tten3 => null() + qvten3 => null() + qrten3 => null() + qsten3 => null() + qgten3 => null() + qiten3 => null() + niten3 => null() + nrten3 => null() + ncten3 => null() + qcten3 => null() + end if unset_extended_diagnostic_pointers + end subroutine mp_thompson_run !>@} diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index f06f92d50..9843550e0 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -302,6 +302,22 @@ type = integer intent = in optional = F +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ext_ndiag3d] + standard_name = number_of_3d_arrays_for_extended_diagnostic_output_from_thompson_microphysics + long_name = number of 3d arrays for extended diagnostic output from thompson microphysics + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -707,6 +723,24 @@ type = integer intent = in optional = F +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys + intent = in + optional = F + [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -724,19 +758,6 @@ type = integer intent = out optional = F -[naux3d] - standard_name = number_of_3d_auxiliary_arrays - long_name = number of 3d auxiliary arrays to output (for debugging) - units = count - dimensions = () - type = integer -[aux3d] - standard_name = auxiliary_3d_arrays - long_name = auxiliary 3d arrays to output (for debugging) - units = none - dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) - type = real - kind = kind_phys ######################################################################## [ccpp-arg-table] From ed4a9de4f428db0caa5c03cd44fd63dc3e22cbcb Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 22 Jun 2021 14:02:00 -0600 Subject: [PATCH 143/165] Bugfixes for updated Thompson diagnostics code --- physics/module_mp_thompson.F90 | 166 ++++++++++++++------------- physics/mp_thompson.F90 | 204 +++++++++++++++++---------------- physics/mp_thompson.meta | 18 +-- 3 files changed, 197 insertions(+), 191 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 0996349a4..041771b78 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1195,7 +1195,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & allocate (tpri_rfz1(kts:kte)) allocate (tprg_rfz1(kts:kte)) allocate (tprs_scw1(kts:kte)) - allocate (tprg_scw1,(kts:kte)) + allocate (tprg_scw1(kts:kte)) allocate (tprg_rcs1(kts:kte)) allocate (tprs_rcs1_s(kts:kte)) allocate (tprs_rcs1_r(kts:kte)) @@ -1211,7 +1211,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & allocate (tprr_rcs1_r(kts:kte)) allocate (tprr_rcs1_s(kts:kte)) allocate (tprv_rev1(kts:kte)) - allocate (txri1,(kts:kte)) + allocate (txri1(kts:kte)) allocate (txrc1(kts:kte)) allocate (tten1(kts:kte)) allocate (qvten1(kts:kte)) @@ -1391,7 +1391,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & vtsk1(k) = 0. txrc1(k) = 0. txri1(k) = 0. - endif + endif initialize_extended_diagnostics enddo if (is_aerosol_aware) then do k = kts, kte @@ -1415,7 +1415,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1, & + kts, kte, dt, i, j, & + ext_diag, vtsk1, prw_vcdc1, prw_vcde1, & tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & @@ -1691,7 +1692,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & deallocate (tpri_rfz1) deallocate (tprg_rfz1) deallocate (tprs_scw1) - deallocate (tprg_scw1,) + deallocate (tprg_scw1) deallocate (tprg_rcs1) deallocate (tprs_rcs1_s) deallocate (tprs_rcs1_r) @@ -1707,7 +1708,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & deallocate (tprr_rcs1_r) deallocate (tprr_rcs1_s) deallocate (tprv_rev1) - deallocate (txri1,) + deallocate (txri1) deallocate (txrc1) deallocate (tten1) deallocate (qvten1) @@ -3689,7 +3690,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtgk(k) = 0. vtck(k) = 0. vtnck(k) = 0. - vtsk1(k) = 0. enddo if (ANY(L_qr .eqv. .true.)) then @@ -4113,95 +4113,99 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qg1d(k) = qg1d(k) + qgten(k)*DT if (qg1d(k) .le. R1) qg1d(k) = 0.0 enddo + ! Diagnostics - do k = kts, kte - if(prw_vcd(k).gt.0)then - prw_vcdc1(k) = prw_vcd(k)*dt - elseif(prw_vcd(k).lt.0)then - prw_vcde1(k) = -1*prw_vcd(k)*dt - endif -!heating/cooling diagnostics - tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + calculate_extended_diagnostics: if (ext_diag) then + do k = kts, kte + if(prw_vcd(k).gt.0)then + prw_vcdc1(k) = prw_vcd(k)*dt + elseif(prw_vcd(k).lt.0)then + prw_vcde1(k) = -1*prw_vcd(k)*dt + endif +!heating/cooling diagnostics + tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - if(pri_ide(k).gt.0)then - tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif + if(pri_ide(k).gt.0)then + tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif - if(prs_ide(k).gt.0)then - tprs_ide1_d(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_ide1_s(k) = -prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prs_ide(k).gt.0)then + tprs_ide1_d(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_ide1_s(k) = -prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif - if(prs_sde(k).gt.0)then - tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prs_sde(k).gt.0)then + tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif - if(prg_gde(k).gt.0)then - tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prg_gde(k).gt.0)then + tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif - tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - if(prs_rcs(k).gt.0)then - tprs_rcs1_s(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_rcs1_r(k) = -prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prs_rcs(k).gt.0)then + tprs_rcs1_s(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_rcs1_r(k) = -prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif - tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - if(prg_rcg(k).gt.0)then - tprg_rcg1_g(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - else - tprg_rcg1_r(k) = -prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prg_rcg(k).gt.0)then + tprg_rcg1_g(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + else + tprg_rcg1_r(k) = -prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif - if(prw_vcd(k).gt.0)then - tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT - else - tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT - endif + if(prw_vcd(k).gt.0)then + tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + else + tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + endif ! cooling terms - tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - if(prr_rcg(k).gt.0)then - tprr_rcg1_r(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - else - tprr_rcg1_g(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prr_rcg(k).gt.0)then + tprr_rcg1_r(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + else + tprr_rcg1_g(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif - if(prr_rcs(k).gt.0)then - tprr_rcs1_r(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - else - tprr_rcs1_s(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - endif + if(prr_rcs(k).gt.0)then + tprr_rcs1_r(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + else + tprr_rcs1_s(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif + + tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT + tten1(k) = tten(k)*DT + qvten1(k) = qvten(k)*DT + qrten1(k) = qrten(k)*DT + qsten1(k) = qsten(k)*DT + qgten1(k) = qgten(k)*DT + niten1(k) = niten(k)*DT + nrten1(k) = nrten(k)*DT + ncten1(k) = ncten(k)*DT + qcten1(k) = qcten(k)*DT + enddo + endif calculate_extended_diagnostics - tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT - tten1(k) = tten(k)*DT - qvten1(k) = qvten(k)*DT - qrten1(k) = qrten(k)*DT - qsten1(k) = qsten(k)*DT - qgten1(k) = qgten(k)*DT - niten1(k) = niten(k)*DT - nrten1(k) = nrten(k)*DT - ncten1(k) = ncten(k)*DT - qcten1(k) = qcten(k)*DT - enddo end subroutine mp_thompson !>@} diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 8bdde0479..0c04f7de5 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -38,7 +38,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & nwfa, nifa, tgrs, prsl, phil, area, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - threads, ext_diag, ext_ndiag3d_in, & + threads, ext_diag, diag3d, & errmsg, errflg) implicit none @@ -84,7 +84,7 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & integer, intent(in ) :: threads ! Extended diagnostics logical, intent(in ) :: ext_diag - integer, intent(in ) :: ext_ndiag3d_in + real(kind_phys), intent(in ) :: diag3d(:,:,:) ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -112,10 +112,12 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & return end if - if (ext_diag and ext_ndiag3d_in /= ext_ndiag3d) then - write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" - errflg = 1 - return + if (ext_diag) then + if (size(diag3d,dim=3) /= ext_ndiag3d) then + write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" + errflg = 1 + return + end if end if ! Call Thompson init @@ -398,7 +400,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer, intent(in) :: mpiroot ! Extended diagnostic output logical, intent(in) :: ext_diag - real(kind_phys), intent(inout) :: diag3d(:,:,:) + real(kind_phys), target, intent(inout) :: diag3d(:,:,:) ! CCPP error handling character(len=*), intent( out) :: errmsg @@ -443,51 +445,51 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! Pointer arrays for extended diagnostics - real(kind_phys), dimension(:,:), pointer :: vts1 => null() - real(kind_phys), dimension(:,:), pointer :: prw_vcdc => null() - real(kind_phys), dimension(:,:), pointer :: prw_vcde => null() - real(kind_phys), dimension(:,:), pointer :: tpri_inu => null() - real(kind_phys), dimension(:,:), pointer :: tpri_ide_d => null() - real(kind_phys), dimension(:,:), pointer :: tpri_ide_s => null() - real(kind_phys), dimension(:,:), pointer :: tprs_ide_d => null() - real(kind_phys), dimension(:,:), pointer :: tprs_ide_s => null() - real(kind_phys), dimension(:,:), pointer :: tprs_sde_d => null() - real(kind_phys), dimension(:,:), pointer :: tprs_sde_s => null() - real(kind_phys), dimension(:,:), pointer :: tprg_gde_d => null() - real(kind_phys), dimension(:,:), pointer :: tprg_gde_s => null() - real(kind_phys), dimension(:,:), pointer :: tpri_iha => null() - real(kind_phys), dimension(:,:), pointer :: tpri_wfz => null() - real(kind_phys), dimension(:,:), pointer :: tpri_rfz => null() - real(kind_phys), dimension(:,:), pointer :: tprg_rfz => null() - real(kind_phys), dimension(:,:), pointer :: tprs_scw => null() - real(kind_phys), dimension(:,:), pointer :: tprg_scw => null() - real(kind_phys), dimension(:,:), pointer :: tprg_rcs => null() - real(kind_phys), dimension(:,:), pointer :: tprs_rcs_s => null() - real(kind_phys), dimension(:,:), pointer :: tprs_rcs_r => null() - real(kind_phys), dimension(:,:), pointer :: tprr_rci => null() - real(kind_phys), dimension(:,:), pointer :: tprg_rcg_g => null() - real(kind_phys), dimension(:,:), pointer :: tprg_rcg_r => null() - real(kind_phys), dimension(:,:), pointer :: tprw_vcd_c => null() - real(kind_phys), dimension(:,:), pointer :: tprw_vcd_e => null() - real(kind_phys), dimension(:,:), pointer :: tprr_sml => null() - real(kind_phys), dimension(:,:), pointer :: tprr_gml => null() - real(kind_phys), dimension(:,:), pointer :: tprr_rcg_r => null() - real(kind_phys), dimension(:,:), pointer :: tprr_rcg_g => null() - real(kind_phys), dimension(:,:), pointer :: tprr_rcs_r => null() - real(kind_phys), dimension(:,:), pointer :: tprr_rcs_s => null() - real(kind_phys), dimension(:,:), pointer :: tprv_rev => null() - real(kind_phys), dimension(:,:), pointer :: txri => null() - real(kind_phys), dimension(:,:), pointer :: txrc => null() - real(kind_phys), dimension(:,:), pointer :: tten3 => null() - real(kind_phys), dimension(:,:), pointer :: qvten3 => null() - real(kind_phys), dimension(:,:), pointer :: qrten3 => null() - real(kind_phys), dimension(:,:), pointer :: qsten3 => null() - real(kind_phys), dimension(:,:), pointer :: qgten3 => null() - real(kind_phys), dimension(:,:), pointer :: qiten3 => null() - real(kind_phys), dimension(:,:), pointer :: niten3 => null() - real(kind_phys), dimension(:,:), pointer :: nrten3 => null() - real(kind_phys), dimension(:,:), pointer :: ncten3 => null() - real(kind_phys), dimension(:,:), pointer :: qcten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcdc => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcde => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_inu => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_ide_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_ide_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_iha => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_wfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_rcs_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_rcs_r => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rci => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcg_g => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcg_r => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_c => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_e => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_sml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_gml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg_r => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg_g => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs_r => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprv_rev => null() + real(kind_phys), dimension(:,:,:), pointer :: txri => null() + real(kind_phys), dimension(:,:,:), pointer :: txrc => null() + real(kind_phys), dimension(:,:,:), pointer :: tten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qvten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qsten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qgten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qiten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: niten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: nrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: ncten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qcten3 => null() ! Initialize the CCPP error handling variables errmsg = '' @@ -625,51 +627,51 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! Set pointers for extended diagnostics set_extended_diagnostic_pointers: if (ext_diag) then - vts1 => diag3d(:,:,1) - prw_vcdc => diag3d(:,:,2) - prw_vcde => diag3d(:,:,3) - tpri_inu => diag3d(:,:,4) - tpri_ide_d => diag3d(:,:,5) - tpri_ide_s => diag3d(:,:,6) - tprs_ide_d => diag3d(:,:,7) - tprs_ide_s => diag3d(:,:,8) - tprs_sde_d => diag3d(:,:,9) - tprs_sde_s => diag3d(:,:,10) - tprg_gde_d => diag3d(:,:,11) - tprg_gde_s => diag3d(:,:,12) - tpri_iha => diag3d(:,:,13) - tpri_wfz => diag3d(:,:,14) - tpri_rfz => diag3d(:,:,15) - tprg_rfz => diag3d(:,:,16) - tprs_scw => diag3d(:,:,17) - tprg_scw => diag3d(:,:,18) - tprg_rcs => diag3d(:,:,19) - tprs_rcs_s => diag3d(:,:,20) - tprs_rcs_r => diag3d(:,:,21) - tprr_rci => diag3d(:,:,22) - tprg_rcg_g => diag3d(:,:,23) - tprg_rcg_r => diag3d(:,:,24) - tprw_vcd_c => diag3d(:,:,25) - tprw_vcd_e => diag3d(:,:,26) - tprr_sml => diag3d(:,:,27) - tprr_gml => diag3d(:,:,28) - tprr_rcg_r => diag3d(:,:,29) - tprr_rcg_g => diag3d(:,:,30) - tprr_rcs_r => diag3d(:,:,31) - tprr_rcs_s => diag3d(:,:,32) - tprv_rev => diag3d(:,:,33) - txri => diag3d(:,:,34) - txrc => diag3d(:,:,35) - tten3 => diag3d(:,:,36) - qvten3 => diag3d(:,:,37) - qrten3 => diag3d(:,:,38) - qsten3 => diag3d(:,:,39) - qgten3 => diag3d(:,:,40) - qiten3 => diag3d(:,:,41) - niten3 => diag3d(:,:,42) - nrten3 => diag3d(:,:,43) - ncten3 => diag3d(:,:,44) - qcten3 => diag3d(:,:,45) + vts1 => diag3d(:,:,1:1) + prw_vcdc => diag3d(:,:,2:2) + prw_vcde => diag3d(:,:,3:3) + tpri_inu => diag3d(:,:,4:4) + tpri_ide_d => diag3d(:,:,5:5) + tpri_ide_s => diag3d(:,:,6:6) + tprs_ide_d => diag3d(:,:,7:7) + tprs_ide_s => diag3d(:,:,8:8) + tprs_sde_d => diag3d(:,:,9:9) + tprs_sde_s => diag3d(:,:,10:10) + tprg_gde_d => diag3d(:,:,11:11) + tprg_gde_s => diag3d(:,:,12:12) + tpri_iha => diag3d(:,:,13:13) + tpri_wfz => diag3d(:,:,14:14) + tpri_rfz => diag3d(:,:,15:15) + tprg_rfz => diag3d(:,:,16:16) + tprs_scw => diag3d(:,:,17:17) + tprg_scw => diag3d(:,:,18:18) + tprg_rcs => diag3d(:,:,19:19) + tprs_rcs_s => diag3d(:,:,20:20) + tprs_rcs_r => diag3d(:,:,21:21) + tprr_rci => diag3d(:,:,22:22) + tprg_rcg_g => diag3d(:,:,23:23) + tprg_rcg_r => diag3d(:,:,24:24) + tprw_vcd_c => diag3d(:,:,25:25) + tprw_vcd_e => diag3d(:,:,26:26) + tprr_sml => diag3d(:,:,27:27) + tprr_gml => diag3d(:,:,28:28) + tprr_rcg_r => diag3d(:,:,29:29) + tprr_rcg_g => diag3d(:,:,30:30) + tprr_rcs_r => diag3d(:,:,31:31) + tprr_rcs_s => diag3d(:,:,32:32) + tprv_rev => diag3d(:,:,33:33) + txri => diag3d(:,:,34:34) + txrc => diag3d(:,:,35:35) + tten3 => diag3d(:,:,36:36) + qvten3 => diag3d(:,:,37:37) + qrten3 => diag3d(:,:,38:38) + qsten3 => diag3d(:,:,39:39) + qgten3 => diag3d(:,:,40:40) + qiten3 => diag3d(:,:,41:41) + niten3 => diag3d(:,:,42:42) + nrten3 => diag3d(:,:,43:43) + ncten3 => diag3d(:,:,44:44) + qcten3 => diag3d(:,:,45:45) end if set_extended_diagnostic_pointers !> - Call mp_gt_driver() with or without aerosols @@ -713,7 +715,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3)) + qcten3=qcten3) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -752,7 +754,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3)) + qcten3=qcten3) end if else if (do_effective_radii) then @@ -793,7 +795,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3)) + qcten3=qcten3) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -831,7 +833,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - qcten3=qcten3)) + qcten3=qcten3) end if end if if (errflg/=0) return diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 9843550e0..85c9f9413 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -310,12 +310,13 @@ type = logical intent = in optional = F -[ext_ndiag3d] - standard_name = number_of_3d_arrays_for_extended_diagnostic_output_from_thompson_microphysics - long_name = number of 3d arrays for extended diagnostic output from thompson microphysics - units = count - dimensions = () - type = integer +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys intent = in optional = F [errmsg] @@ -735,12 +736,11 @@ standard_name = extended_diagnostics_output_from_thompson_microphysics long_name = set of 3d arrays for extended diagnostics output from thompson microphysics units = none - dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) type = real kind = kind_phys - intent = in + intent = inout optional = F - [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 4e39a44fa7913c04aaad705714a8e34f11c3bded Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 22 Jun 2021 15:42:21 -0600 Subject: [PATCH 144/165] Remove blank line at the top of physics/module_mp_thompson.F90 --- physics/module_mp_thompson.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 041771b78..cc0da1f81 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1,4 +1,3 @@ - !>\file module_mp_thompson.F90 !! This file contains the entity of GSD Thompson MP scheme. From 2a61a8ded1567a7ef4024e4b888bc56c05f27795 Mon Sep 17 00:00:00 2001 From: Eric Aligo Date: Wed, 23 Jun 2021 14:22:38 +0000 Subject: [PATCH 145/165] Fix bugs in diagnostics and dimension for aux3d array in meta file --- physics/module_mp_thompson.F90 | 143 +++++++++++++---------------- physics/mp_thompson.F90 | 160 ++++++++++++++++----------------- physics/mp_thompson.meta | 2 +- 3 files changed, 142 insertions(+), 163 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index cd4d84d8d..78ccafa17 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -990,15 +990,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & reset_dBZ, istep, nsteps, & errmsg, errflg, vts1, prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide_d, tprs_ide_s, & - tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tpri_ide_s, tprs_ide,tprs_sde_d, & + tprs_sde_s, tprg_gde_d, & tprg_gde_s, tpri_iha, tpri_wfz, & tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs_s, tprs_rcs_r, & - tprr_rci, tprg_rcg_g, tprg_rcg_r, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg_r, tprr_rcg_g, & - tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, txri, & txrc, tten3, qvten3, qrten3, qsten3, & qgten3, qiten3, niten3, nrten3, ncten3, & qcten3) @@ -1014,15 +1014,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & vts1, prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & - tpri_ide_s, tprs_ide_d, tprs_ide_s, & + tpri_ide_s, tprs_ide, & tprs_sde_d, tprs_sde_s, tprg_gde_d, & tprg_gde_s, tpri_iha, tpri_wfz, & tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & - tprg_rcs, tprs_rcs_s, tprs_rcs_r, & - tprr_rci, tprg_rcg_g, tprg_rcg_r, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & tprw_vcd_c, tprw_vcd_e, tprr_sml, & - tprr_gml, tprr_rcg_r, tprr_rcg_g, & - tprr_rcs_r, tprr_rcs_s, tprv_rev, txri, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, txri, & txrc, tten3, qvten3, qrten3, qsten3, & qgten3, qiten3, niten3, nrten3, ncten3, & qcten3 @@ -1070,15 +1070,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(kts:kte):: & vtsk1, prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & tprg_gde1_s, tpri_iha1, tpri_wfz1, & tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & - tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & - tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, txri1,& txrc1, tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, & qcten1 @@ -1286,8 +1286,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tpri_inu1(k) = 0. tpri_ide1_d(k) = 0. tpri_ide1_s(k) = 0. - tprs_ide1_d(k) = 0. - tprs_ide1_s(k) = 0. + tprs_ide1(k) = 0. tprs_sde1_d(k) = 0. tprs_sde1_s(k) = 0. tprg_gde1_d(k) = 0. @@ -1299,19 +1298,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprg_scw1(k) = 0. tprs_scw1(k) = 0. tprg_rcs1(k) = 0. - tprs_rcs1_s(k) = 0. - tprs_rcs1_r(k) = 0. + tprs_rcs1(k) = 0. tprr_rci1(k) = 0. - tprg_rcg1_g(k) = 0. - tprg_rcg1_r(k) = 0. + tprg_rcg1(k) = 0. tprw_vcd1_c(k) = 0. tprw_vcd1_e(k) = 0. tprr_sml1(k) = 0. tprr_gml1(k) = 0. - tprr_rcg1_r(k) = 0. - tprr_rcg1_g(k) = 0. - tprr_rcs1_r(k) = 0. - tprr_rcs1_s(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. tprv_rev1(k) = 0. txrc1(k) = 0. txri1(k) = 0. @@ -1349,14 +1344,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & #endif rand1, rand2, rand3, & kts, kte, dt, i, j, vtsk1, prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& - tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1,& + tprs_sde1_d, tprs_sde1_s, & tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & - tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & - tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1,& txri1, txrc1, tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, qcten1) @@ -1416,10 +1411,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) - tprs_ide_d(i,k,j) = tprs_ide_d(i,k,j) + tprs_ide1_d(k) + tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) @@ -1428,19 +1425,15 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) - tprs_rcs_s(i,k,j) = tprs_rcs_s(i,k,j) + tprs_rcs1_s(k) - tprs_rcs_r(i,k,j) = tprs_rcs_r(i,k,j) + tprs_rcs1_r(k) + tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) - tprg_rcg_g(i,k,j) = tprg_rcg_g(i,k,j) + tprg_rcg1_g(k) - tprg_rcg_r(i,k,j) = tprg_rcg_r(i,k,j) + tprg_rcg1_r(k) + tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) - tprr_rcg_r(i,k,j) = tprr_rcg_r(i,k,j) + tprr_rcg1_r(k) - tprr_rcg_g(i,k,j) = tprr_rcg_g(i,k,j) + tprr_rcg1_g(k) - tprr_rcs_r(i,k,j) = tprr_rcs_r(i,k,j) + tprr_rcs1_r(k) - tprr_rcs_s(i,k,j) = tprr_rcs_s(i,k,j) + tprr_rcs1_s(k) + tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) + tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) txri(i,k,j) = txri(i,k,j) + txri1(k) txrc(i,k,j) = txrc(i,k,j) + txrc1(k) @@ -1673,14 +1666,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & #endif rand1, rand2, rand3, & kts, kte, dt, ii, jj,vtsk1, prw_vcdc1, prw_vcde1, & - tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1_d,& - tprs_ide1_s, tprs_sde1_d, tprs_sde1_s, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, & tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, tprr_rci1, & - tprg_rcg1_g, tprg_rcg1_r, tprw_vcd1_c, & - tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1_r, & - tprr_rcg1_g, tprr_rcs1_r, tprr_rcs1_s, tprv_rev1,& + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1,& txri1, txrc1, tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, qcten1) #ifdef MPI @@ -1700,15 +1693,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, DIMENSION(kts:kte), INTENT(OUT):: & vtsk1, prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & - tpri_ide1_s, tprs_ide1_d, tprs_ide1_s, & + tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & tprg_gde1_s, tpri_iha1, tpri_wfz1, & tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& - tprg_rcs1, tprs_rcs1_s, tprs_rcs1_r, & - tprr_rci1, tprg_rcg1_g, tprg_rcg1_r, & + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & - tprr_gml1, tprr_rcg1_r, tprr_rcg1_g, & - tprr_rcs1_r, tprr_rcs1_s, tprv_rev1, txri1,& + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, txri1,& txrc1, tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, & qcten1 @@ -1919,8 +1912,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tpri_inu1(k) = 0. tpri_ide1_d(k) = 0. tpri_ide1_s(k) = 0. - tprs_ide1_d(k) = 0. - tprs_ide1_s(k) = 0. + tprs_ide1(k) = 0. tprs_sde1_d(k) = 0. tprs_sde1_s(k) = 0. tprg_gde1_d(k) = 0. @@ -1932,19 +1924,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprg_scw1(k) = 0. tprs_scw1(k) = 0. tprg_rcs1(k) = 0. - tprs_rcs1_s(k) = 0. - tprs_rcs1_r(k) = 0. + tprs_rcs1(k) = 0. tprr_rci1(k) = 0. - tprg_rcg1_g(k) = 0. - tprg_rcg1_r(k) = 0. + tprg_rcg1(k) = 0. tprw_vcd1_c(k) = 0. tprw_vcd1_e(k) = 0. tprr_sml1(k) = 0. tprr_gml1(k) = 0. - tprr_rcg1_r(k) = 0. - tprr_rcg1_g(k) = 0. - tprr_rcs1_r(k) = 0. - tprr_rcs1_s(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. tprv_rev1(k) = 0. txrc1(k) = 0. txri1(k) = 0. @@ -3994,10 +3982,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT endif - if(prs_ide(k).gt.0)then - tprs_ide1_d(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_ide1_s(k) = -prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + if(temp(k).lt.T_0)then + tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT endif if(prs_sde(k).gt.0)then @@ -4020,18 +4006,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - if(prs_rcs(k).gt.0)then - tprs_rcs1_s(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - else - tprs_rcs1_r(k) = -prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + if(temp(k).lt.T_0)then + tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT endif tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - if(prg_rcg(k).gt.0)then - tprg_rcg1_g(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT - else - tprg_rcg1_r(k) = -prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + if(temp(k).lt.T_0)then + tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT endif if(prw_vcd(k).gt.0)then @@ -4044,21 +4026,18 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - if(prr_rcg(k).gt.0)then - tprr_rcg1_r(k) = prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - else - tprr_rcg1_g(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + if(temp(k).ge.T_0)then + tprr_rcg1(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT endif - if(prr_rcs(k).gt.0)then - tprr_rcs1_r(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT - else - tprr_rcs1_s(k) = prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + if(temp(k).ge.T_0)then + tprr_rcs1(k) = -prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT endif tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT tten1(k) = tten(k)*DT qvten1(k) = qvten(k)*DT + qiten1(k) = qiten(k)*DT qrten1(k) = qrten(k)*DT qsten1(k) = qsten(k)*DT qgten1(k) = qgten(k)*DT diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1a74b6758..93e4d866c 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -589,26 +589,26 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & vts1=aux3d(:,:,1), & prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + tpri_ide_s=aux3d(:,:,6), tprs_ide=aux3d(:,:,7), & + tprs_sde_d=aux3d(:,:,8), & + tprs_sde_s=aux3d(:,:,9), tprg_gde_d=aux3d(:,:,10), & + tprg_gde_s=aux3d(:,:,11), tpri_iha=aux3d(:,:,12), & + tpri_wfz=aux3d(:,:,13), tpri_rfz=aux3d(:,:,14), & + tprg_rfz=aux3d(:,:,15), tprs_scw=aux3d(:,:,16), & + tprg_scw=aux3d(:,:,17), tprg_rcs=aux3d(:,:,18), & + tprs_rcs=aux3d(:,:,19), & + tprr_rci=aux3d(:,:,20), tprg_rcg=aux3d(:,:,21), & + tprw_vcd_c=aux3d(:,:,22), & + tprw_vcd_e=aux3d(:,:,23), tprr_sml=aux3d(:,:,24), & + tprr_gml=aux3d(:,:,25), tprr_rcg=aux3d(:,:,26), & + tprr_rcs=aux3d(:,:,27), & + tprv_rev=aux3d(:,:,28), & + txri=aux3d(:,:,29), txrc=aux3d(:,:,30), tten3=aux3d(:,:,31), & + qvten3=aux3d(:,:,32) ,qrten3=aux3d(:,:,33), & + qsten3=aux3d(:,:,34), qgten3=aux3d(:,:,35), & + qiten3=aux3d(:,:,36), niten3=aux3d(:,:,37), & + nrten3=aux3d(:,:,38) ,ncten3=aux3d(:,:,39), & + qcten3=aux3d(:,:,40)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & @@ -632,26 +632,26 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & vts1=aux3d(:,:,1), & prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + tpri_ide_s=aux3d(:,:,6), tprs_ide=aux3d(:,:,7), & + tprs_sde_d=aux3d(:,:,8), & + tprs_sde_s=aux3d(:,:,9), tprg_gde_d=aux3d(:,:,10), & + tprg_gde_s=aux3d(:,:,11), tpri_iha=aux3d(:,:,12), & + tpri_wfz=aux3d(:,:,13), tpri_rfz=aux3d(:,:,14), & + tprg_rfz=aux3d(:,:,15), tprs_scw=aux3d(:,:,16), & + tprg_scw=aux3d(:,:,17), tprg_rcs=aux3d(:,:,18), & + tprs_rcs=aux3d(:,:,19), & + tprr_rci=aux3d(:,:,20), tprg_rcg=aux3d(:,:,21), & + tprw_vcd_c=aux3d(:,:,22), & + tprw_vcd_e=aux3d(:,:,23), tprr_sml=aux3d(:,:,24), & + tprr_gml=aux3d(:,:,25), tprr_rcg=aux3d(:,:,26), & + tprr_rcs=aux3d(:,:,27), & + tprv_rev=aux3d(:,:,28), & + txri=aux3d(:,:,29), txrc=aux3d(:,:,30), tten3=aux3d(:,:,31), & + qvten3=aux3d(:,:,32) ,qrten3=aux3d(:,:,33), & + qsten3=aux3d(:,:,34), qgten3=aux3d(:,:,35), & + qiten3=aux3d(:,:,36), niten3=aux3d(:,:,37), & + nrten3=aux3d(:,:,38) ,ncten3=aux3d(:,:,39), & + qcten3=aux3d(:,:,40)) end if else if (do_effective_radii) then @@ -677,26 +677,26 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & vts1=aux3d(:,:,1), & prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37) ,qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43) ,ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + tpri_ide_s=aux3d(:,:,6), tprs_ide=aux3d(:,:,7), & + tprs_sde_d=aux3d(:,:,8), & + tprs_sde_s=aux3d(:,:,9), tprg_gde_d=aux3d(:,:,10), & + tprg_gde_s=aux3d(:,:,11), tpri_iha=aux3d(:,:,12), & + tpri_wfz=aux3d(:,:,13), tpri_rfz=aux3d(:,:,14), & + tprg_rfz=aux3d(:,:,15), tprs_scw=aux3d(:,:,16), & + tprg_scw=aux3d(:,:,17), tprg_rcs=aux3d(:,:,18), & + tprs_rcs=aux3d(:,:,19), & + tprr_rci=aux3d(:,:,20), tprg_rcg=aux3d(:,:,21), & + tprw_vcd_c=aux3d(:,:,22), & + tprw_vcd_e=aux3d(:,:,23), tprr_sml=aux3d(:,:,24), & + tprr_gml=aux3d(:,:,25), tprr_rcg=aux3d(:,:,26), & + tprr_rcs=aux3d(:,:,27), & + tprv_rev=aux3d(:,:,28), & + txri=aux3d(:,:,29), txrc=aux3d(:,:,30), tten3=aux3d(:,:,31), & + qvten3=aux3d(:,:,32) ,qrten3=aux3d(:,:,33), & + qsten3=aux3d(:,:,34), qgten3=aux3d(:,:,35), & + qiten3=aux3d(:,:,36), niten3=aux3d(:,:,37), & + nrten3=aux3d(:,:,38) ,ncten3=aux3d(:,:,39), & + qcten3=aux3d(:,:,40)) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & @@ -719,26 +719,26 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & vts1=aux3d(:,:,1), & prw_vcdc=aux3d(:,:,2), prw_vcde=aux3d(:,:,3), & tpri_inu=aux3d(:,:,4), tpri_ide_d=aux3d(:,:,5), & - tpri_ide_s=aux3d(:,:,6), tprs_ide_d=aux3d(:,:,7), & - tprs_ide_s=aux3d(:,:,8), tprs_sde_d=aux3d(:,:,9), & - tprs_sde_s=aux3d(:,:,10), tprg_gde_d=aux3d(:,:,11), & - tprg_gde_s=aux3d(:,:,12), tpri_iha=aux3d(:,:,13), & - tpri_wfz=aux3d(:,:,14), tpri_rfz=aux3d(:,:,15), & - tprg_rfz=aux3d(:,:,16), tprs_scw=aux3d(:,:,17), & - tprg_scw=aux3d(:,:,18), tprg_rcs=aux3d(:,:,19), & - tprs_rcs_s=aux3d(:,:,20), tprs_rcs_r=aux3d(:,:,21), & - tprr_rci=aux3d(:,:,22), tprg_rcg_g=aux3d(:,:,23), & - tprg_rcg_r=aux3d(:,:,24), tprw_vcd_c=aux3d(:,:,25), & - tprw_vcd_e=aux3d(:,:,26), tprr_sml=aux3d(:,:,27), & - tprr_gml=aux3d(:,:,28), tprr_rcg_r=aux3d(:,:,29), & - tprr_rcg_g=aux3d(:,:,30), tprr_rcs_r=aux3d(:,:,31), & - tprr_rcs_s=aux3d(:,:,32), tprv_rev=aux3d(:,:,33), & - txri=aux3d(:,:,34), txrc=aux3d(:,:,35), tten3=aux3d(:,:,36), & - qvten3=aux3d(:,:,37), qrten3=aux3d(:,:,38), & - qsten3=aux3d(:,:,39), qgten3=aux3d(:,:,40), & - qiten3=aux3d(:,:,41), niten3=aux3d(:,:,42), & - nrten3=aux3d(:,:,43), ncten3=aux3d(:,:,44), & - qcten3=aux3d(:,:,45)) + tpri_ide_s=aux3d(:,:,6), tprs_ide=aux3d(:,:,7), & + tprs_sde_d=aux3d(:,:,8), & + tprs_sde_s=aux3d(:,:,9), tprg_gde_d=aux3d(:,:,10), & + tprg_gde_s=aux3d(:,:,11), tpri_iha=aux3d(:,:,12), & + tpri_wfz=aux3d(:,:,13), tpri_rfz=aux3d(:,:,14), & + tprg_rfz=aux3d(:,:,15), tprs_scw=aux3d(:,:,16), & + tprg_scw=aux3d(:,:,17), tprg_rcs=aux3d(:,:,18), & + tprs_rcs=aux3d(:,:,19), & + tprr_rci=aux3d(:,:,20), tprg_rcg=aux3d(:,:,21), & + tprw_vcd_c=aux3d(:,:,22), & + tprw_vcd_e=aux3d(:,:,23), tprr_sml=aux3d(:,:,24), & + tprr_gml=aux3d(:,:,25), tprr_rcg=aux3d(:,:,26), & + tprr_rcs=aux3d(:,:,27), & + tprv_rev=aux3d(:,:,28), & + txri=aux3d(:,:,29), txrc=aux3d(:,:,30), tten3=aux3d(:,:,31), & + qvten3=aux3d(:,:,32) ,qrten3=aux3d(:,:,33), & + qsten3=aux3d(:,:,34), qgten3=aux3d(:,:,35), & + qiten3=aux3d(:,:,36), niten3=aux3d(:,:,37), & + nrten3=aux3d(:,:,38) ,ncten3=aux3d(:,:,39), & + qcten3=aux3d(:,:,40)) end if end if if (errflg/=0) return diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index f06f92d50..efa819ca2 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -734,7 +734,7 @@ standard_name = auxiliary_3d_arrays long_name = auxiliary 3d arrays to output (for debugging) units = none - dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_3d_auxiliary_arrays) type = real kind = kind_phys From 1a0bf7bf8e6ed2667c318cbd9005b1aba895f66b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 23 Jun 2021 14:23:31 -0600 Subject: [PATCH 146/165] Fix bug in physics/m_micro.F90: arrays on interfaces should start at 0 --- physics/m_micro.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 7624d7e3e..53ba82392 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -180,7 +180,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & real (kind=kind_phys), dimension(:,:),intent(in) :: & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i - real (kind=kind_phys), dimension(:,:),intent(in):: prsi_i, phii + real (kind=kind_phys), dimension(:,0:),intent(in):: prsi_i, phii ! GJF* These variables are conditionally allocated depending on whether the ! Morrison-Gettelman microphysics is used, so they must be declared ! using assumed shape. From 7eba0956d8cec959aa25c3bc95d061014307dea3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 23 Jun 2021 14:30:17 -0600 Subject: [PATCH 147/165] Add logic to reset extended diagnostics for Thompson MP based on reset flag for maximum hourly fields --- physics/mp_thompson.F90 | 10 +++++++--- physics/mp_thompson.meta | 8 ++++++++ 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 87971e66c..7d8042893 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -22,7 +22,7 @@ module mp_thompson logical :: is_initialized = .False. - integer, parameter :: ext_ndiag3d = 45 + integer, parameter :: ext_ndiag3d = 40 contains @@ -339,8 +339,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & prcp, rain, graupel, ice, snow, sr, & refl_10cm, reset_dBZ, do_radar_ref, & re_cloud, re_ice, re_snow, & - mpicomm, mpirank, mpiroot, & - blkno, ext_diag, diag3d, & + mpicomm, mpirank, mpiroot, blkno, & + ext_diag, diag3d, reset_diag3d, & errmsg, errflg) implicit none @@ -401,6 +401,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! Extended diagnostic output logical, intent(in) :: ext_diag real(kind_phys), target, intent(inout) :: diag3d(:,:,:) + logical, intent(in) :: reset_diag3d ! CCPP error handling character(len=*), intent( out) :: errmsg @@ -622,6 +623,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! Set pointers for extended diagnostics set_extended_diagnostic_pointers: if (ext_diag) then + if (reset_diag3d) then + diag3d = 0.0 + end if vts1 => diag3d(:,:,1:1) prw_vcdc => diag3d(:,:,2:2) prw_vcde => diag3d(:,:,3:3) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 85c9f9413..194400d5b 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -741,6 +741,14 @@ kind = kind_phys intent = inout optional = F +[reset_diag3d] + standard_name = flag_reset_maximum_hourly_fields + long_name = flag for resetting maximum hourly fields + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 1c69f76869a990cb014c52272b0d9bad5426413d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 23 Jun 2021 15:37:26 -0600 Subject: [PATCH 148/165] Use separate flag for resetting extended diagnostics for Thompson MP --- physics/mp_thompson.meta | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 194400d5b..1ab496c25 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -742,8 +742,8 @@ intent = inout optional = F [reset_diag3d] - standard_name = flag_reset_maximum_hourly_fields - long_name = flag for resetting maximum hourly fields + standard_name = flag_reset_extended_diagnostics_output_arrays_from_thompson_microphysics + long_name = flag for resetting extended diagnostics output arrays from thompson microphysics units = flag dimensions = () type = logical From 55398eab58a1d5ae63dc5ce3da39a6c175848ced Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 23 Jun 2021 17:26:14 -0600 Subject: [PATCH 149/165] Reenable commented-out code in physics/mp_thompson.F90 --- physics/mp_thompson.F90 | 226 +++++++++++++++++++--------------------- 1 file changed, 109 insertions(+), 117 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 7d8042893..9548d0920 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -701,133 +701,125 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & tprs_rcs=tprs_rcs, & - tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, & - tprw_vcd_c=tprw_vcd_c, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - tprr_rcg=tprr_rcg, & - tprr_rcs=tprr_rcs, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & qcten3=qcten3) else - !!! call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - !!! nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - !!! tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & - !!! rainnc=rain_mp, rainncv=delta_rain_mp, & - !!! snownc=snow_mp, snowncv=delta_snow_mp, & - !!! icenc=ice_mp, icencv=delta_ice_mp, & - !!! graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & - !!! refl_10cm=refl_10cm, & - !!! diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & - !!! has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - !!! rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - !!! ! DH* 2020-06-05 not passing this optional argument, see - !!! ! comment in module_mp_thompson.F90 / mp_gt_driver - !!! !rand_pert=rand_pert, & - !!! ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & - !!! ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & - !!! its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - !!! reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - !!! first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - !!! ! Extended diagnostics - !!! ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & - !!! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - !!! tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & - !!! tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & - !!! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - !!! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - !!! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - !!! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - !!! tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & - !!! tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & - !!! tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & - !!! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - !!! tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & - !!! tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & - !!! tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & - !!! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - !!! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - !!! qcten3=qcten3) + call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & + ! DH* 2020-06-05 not passing this optional argument, see + ! comment in module_mp_thompson.F90 / mp_gt_driver + !rand_pert=rand_pert, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) end if else if (do_effective_radii) then - !!!call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - !!! tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & - !!! rainnc=rain_mp, rainncv=delta_rain_mp, & - !!! snownc=snow_mp, snowncv=delta_snow_mp, & - !!! icenc=ice_mp, icencv=delta_ice_mp, & - !!! graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & - !!! refl_10cm=refl_10cm, & - !!! diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & - !!! re_cloud=re_cloud, re_ice=re_ice, re_snow=re_snow, & - !!! has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - !!! rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - !!! ! DH* 2020-06-05 not passing this optional argument, see - !!! ! comment in module_mp_thompson.F90 / mp_gt_driver - !!! !rand_pert=rand_pert, & - !!! ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & - !!! ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & - !!! its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - !!! reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - !!! first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - !!! ! Extended diagnostics - !!! ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & - !!! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - !!! tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & - !!! tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & - !!! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - !!! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - !!! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - !!! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - !!! tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & - !!! tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & - !!! tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & - !!! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - !!! tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & - !!! tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & - !!! tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & - !!! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - !!! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - !!! qcten3=qcten3) + call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + re_cloud=re_cloud, re_ice=re_ice, re_snow=re_snow, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & + ! DH* 2020-06-05 not passing this optional argument, see + ! comment in module_mp_thompson.F90 / mp_gt_driver + !rand_pert=rand_pert, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) else - !!!call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - !!! tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & - !!! rainnc=rain_mp, rainncv=delta_rain_mp, & - !!! snownc=snow_mp, snowncv=delta_snow_mp, & - !!! icenc=ice_mp, icencv=delta_ice_mp, & - !!! graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & - !!! refl_10cm=refl_10cm, & - !!! diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & - !!! has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & - !!! rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & - !!! ! DH* 2020-06-05 not passing this optional argument, see - !!! ! comment in module_mp_thompson.F90 / mp_gt_driver - !!! !rand_pert=rand_pert, & - !!! ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & - !!! ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & - !!! its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & - !!! reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & - !!! first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & - !!! ! Extended diagnostics - !!! ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & - !!! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & - !!! tpri_ide_s=tpri_ide_s, tprs_ide_d=tprs_ide_d, & - !!! tprs_ide_s=tprs_ide_s, tprs_sde_d=tprs_sde_d, & - !!! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & - !!! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & - !!! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & - !!! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & - !!! tprs_rcs_s=tprs_rcs_s, tprs_rcs_r=tprs_rcs_r, & - !!! tprr_rci=tprr_rci, tprg_rcg_g=tprg_rcg_g, & - !!! tprg_rcg_r=tprg_rcg_r, tprw_vcd_c=tprw_vcd_c, & - !!! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & - !!! tprr_rcg_r=tprr_rcg_r, tprr_rcg_g=tprr_rcg_g, & - !!! tprr_rcs_r=tprr_rcs_r, tprr_rcs_s=tprr_rcs_s, & - !!! tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & - !!! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & - !!! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & - !!! qcten3=qcten3) + call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + rand_perturb_on=rand_perturb_on, kme_stoch=kme_stoch, & + ! DH* 2020-06-05 not passing this optional argument, see + ! comment in module_mp_thompson.F90 / mp_gt_driver + !rand_pert=rand_pert, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) end if end if if (errflg/=0) return From 0a6f3c1b0841a2881bcc93c00a29cfc6fec44edf Mon Sep 17 00:00:00 2001 From: grantfirl Date: Fri, 25 Jun 2021 13:55:18 -0600 Subject: [PATCH 150/165] change style in GFS_phys_time_vary.scm.F90 and remove variables in GFS_time_vary_pre.scm.F90 to match FV3 versions in ccpp-physics PR#662 --- physics/GFS_phys_time_vary.scm.F90 | 37 +++++++++++++++--------------- physics/GFS_time_vary_pre.scm.F90 | 5 ++-- physics/GFS_time_vary_pre.scm.meta | 16 ------------- 3 files changed, 20 insertions(+), 38 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index e1b5c3d9b..e0f380276 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -69,7 +69,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -281,10 +281,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !> - Call setindxci() to initialize IN and CCN data @@ -691,8 +691,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix, kdt_rad - real(kind=kind_phys) :: sec_zero, rsnow + integer :: i, j, k, iseed, iskip, ix real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(cny) real(kind=kind_phys) :: rndval(cnx*cny*nrcm) @@ -792,18 +791,18 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Not needed for SCM: !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs - !if (nscyc > 0) then - ! if (mod(kdt,nscyc) == 1) THEN - ! call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & - ! input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - ! use_ufo, nst_anl, fhcyc, phour, lakefrac, min_seaice, min_lakeice, & - ! frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & - ! tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & - ! zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & - ! stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & - ! xlat_d, xlon_d, slmsk, imap, jmap) - ! endif - !endif + ! if (nscyc > 0) then + ! if (mod(kdt,nscyc) == 1) THEN + ! call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + ! input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & + ! use_ufo, nst_anl, fhcyc, phour, landfrac, lakefrac, min_seaice, min_lakeice,& + ! frac_grid, smc, slc, stc, smois, sh2o, tslb, tiice, tg3, tref, tsfc, & + ! tsfco, tisfc, hice, fice, facsf, facwf, alvsf, alvwf, alnsf, alnwf, & + ! zorli, zorll, zorlo, weasd, slope, snoalb, canopy, vfrac, vtype, & + ! stype, shdmin, shdmax, snowd, cv, cvb, cvt, oro, oro_uf, & + ! xlat_d, xlon_d, slmsk, imap, jmap) + ! endif + ! endif end subroutine GFS_phys_time_vary_timestep_init !! @} diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index c9ee9f946..0c34ca735 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -65,7 +65,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -75,8 +75,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, ns integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 5033f7988..5b6648a96 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -76,22 +76,6 @@ kind = kind_phys intent = in optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls From 4ccbbeb4b8d244b67493099426bbde87608be9c9 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 26 Jun 2021 13:13:05 -0600 Subject: [PATCH 151/165] Bugfix in Thompson MP, pass correct timestep to core routine --- physics/mp_thompson.F90 | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1d235c3e6..0ed8f4a81 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -467,6 +467,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & !> - Also, hydrometeor variables are mass or number mixing ratio !> - either kg of species per kg of dry air, or per kg of (dry + vapor). +#if 0 + if (istep==1) then +#endif ! DH* - do this only if istep == 1? Would be ok if it was ! guaranteed that nothing else in the same subcycle group ! was using these arrays, but it is somewhat dangerous. @@ -488,6 +491,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if end if ! *DH +#if 0 + endif +#endif !> - Density of air in kg m-3 rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) @@ -565,7 +571,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -586,7 +592,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -607,7 +613,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -627,7 +633,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -652,6 +658,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! guaranteed that nothing else in the same subcycle group ! was using these arrays, but it is somewhat dangerous. +#if 0 + if(istep==nsteps) then +#endif !> - Convert water vapor mixing ratio back to specific humidity spechum = qv/(1.0_kind_phys+qv) @@ -671,7 +680,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if end if ! *DH - +#if 0 + endif +#endif !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in Thompson MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) prcp = prcp + max(0.0, delta_rain_mp/1000.0_kind_phys) From 1ccfb69bd8fc55e044875629506114cd2e34538c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 28 Jun 2021 07:10:01 -0600 Subject: [PATCH 152/165] Remove test code from physics/mp_thompson.F90 --- physics/mp_thompson.F90 | 21 +++++---------------- 1 file changed, 5 insertions(+), 16 deletions(-) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 0ed8f4a81..f4720eb72 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -467,9 +467,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & !> - Also, hydrometeor variables are mass or number mixing ratio !> - either kg of species per kg of dry air, or per kg of (dry + vapor). -#if 0 - if (istep==1) then -#endif ! DH* - do this only if istep == 1? Would be ok if it was ! guaranteed that nothing else in the same subcycle group ! was using these arrays, but it is somewhat dangerous. @@ -491,9 +488,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if end if ! *DH -#if 0 - endif -#endif !> - Density of air in kg m-3 rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) @@ -571,7 +565,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -592,7 +586,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -613,7 +607,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & else if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -633,7 +627,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -658,9 +652,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ! guaranteed that nothing else in the same subcycle group ! was using these arrays, but it is somewhat dangerous. -#if 0 - if(istep==nsteps) then -#endif !> - Convert water vapor mixing ratio back to specific humidity spechum = qv/(1.0_kind_phys+qv) @@ -680,9 +671,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if end if ! *DH -#if 0 - endif -#endif + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in Thompson MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) prcp = prcp + max(0.0, delta_rain_mp/1000.0_kind_phys) From fe5f2fd31074a84486abc874d427330bca08f8cd Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 29 Jun 2021 20:23:00 -0400 Subject: [PATCH 153/165] fix some issues related to running rap and hrrr rt tests --- physics/GFS_debug.F90 | 8 ++++---- physics/GFS_surface_composites.F90 | 2 +- physics/sfc_drv_ruc.meta | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 00e7865ef..7a984e8ba 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1307,8 +1307,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slopetype ', Interstitial%slopetype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%soiltype ', Interstitial%soiltype ) @@ -1342,8 +1342,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegtype ', Interstitial%vegtype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_water ', Interstitial%weasd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 06fd5f4b9..f3b87d1f5 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -202,7 +202,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, lkm, lsm, lsm_noahmp, tprcp_lnd(i) = tprcp(i) tprcp_ice(i) = tprcp(i) if (wet(i)) then ! Water -! uustar_wat(i) = uustar(i) + uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) !-- reference emiss value for surface emissivity in setemis diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 7a7fc5075..1e6d38fc5 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -845,8 +845,8 @@ intent = in optional = F [lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical From f35d72dcbc29a476c79848d8dbbd2a62733bbd5f Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Jun 2021 08:52:55 -0600 Subject: [PATCH 154/165] Bugfix in physics/rascnv.F90, avoid out of bound reads --- physics/rascnv.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index ee58baecd..e41ac7abd 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -401,10 +401,12 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & real fscav_(ntr+2) ! Fraction scavenged per km ! fscav_ = -999.0_kp ! By default no scavenging - if (ntr > 0 .and. fscav(1) > zero) then - do i=1,ntr - fscav_(i) = fscav(i) - enddo + if (ntr > 0) then + if (fscav(1) > zero) then + do i=1,ntr + fscav_(i) = fscav(i) + enddo + endif endif trcmin = -99999.0_kp if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kp From 7f6e45e756028c26443d9579248a0c49de52024e Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Jun 2021 11:56:35 -0600 Subject: [PATCH 155/165] Update RAS to match GOCART changes to fscav --- physics/rascnv.F90 | 20 +++++++++++--------- physics/rascnv.meta | 16 ++++++++++++++++ 2 files changed, 27 insertions(+), 9 deletions(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index e41ac7abd..a0a52705a 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -297,7 +297,7 @@ end subroutine rascnv_finalize !! \section arg_table_rascnv_run Argument Table !! \htmlinclude rascnv_run.html !! - subroutine rascnv_run(IM, k, ntr, dt, dtf & + subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & &, ccwf, area, dxmin, dxinv & &, psauras, prauras, wminras, dlqf, flipv & &, me, rannum, nrcm, mp_phys, mp_phys_mg & @@ -332,7 +332,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! logical, intent(in) :: flipv ! - integer, intent(in) :: im, k, ntr, me, nrcm, ntk, kdt & + integer, intent(in) :: im, k, itc, ntc, ntr, me, nrcm, ntk, kdt & &, mp_phys, mp_phys_mg integer, dimension(:), intent(out) :: kbot, ktop integer, dimension(:), intent(inout) :: kcnv @@ -401,13 +401,15 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & real fscav_(ntr+2) ! Fraction scavenged per km ! fscav_ = -999.0_kp ! By default no scavenging - if (ntr > 0) then - if (fscav(1) > zero) then - do i=1,ntr - fscav_(i) = fscav(i) - enddo - endif - endif + if (itc > 0 .and. ntc > 0) then + if (ntr >= itc + ntc - 3) then + fscav_(itc:ntc-1) = fscav + else + errmsg = 'Error in rascnv_run: test ntr >= itc + ntc - 3 FAILED' + errflg = 1 + return + end if + end if trcmin = -99999.0_kp if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kp diff --git a/physics/rascnv.meta b/physics/rascnv.meta index 4babf620d..40ae7d684 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -210,6 +210,22 @@ type = integer intent = in optional = F +[itc] + standard_name = number_of_aerosol_tracers_for_convection + long_name = number of aerosol tracers transported/scavenged by convection + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntc] + standard_name = number_of_chemical_tracers + long_name = number of chemical tracers + units = count + dimensions = () + type = integer + intent = in + optional = F [ntr] standard_name = number_of_tracers_for_samf long_name = number of tracers for scale-aware mass flux schemes From 13625cbd088a4028d545e2c163a1481ebec46181 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Jun 2021 13:48:02 -0600 Subject: [PATCH 156/165] Correct indices in array assignment in physics/rascnv.F90 --- physics/rascnv.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index a0a52705a..31386b180 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -403,7 +403,7 @@ subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & fscav_ = -999.0_kp ! By default no scavenging if (itc > 0 .and. ntc > 0) then if (ntr >= itc + ntc - 3) then - fscav_(itc:ntc-1) = fscav + fscav_(itc:ntc) = fscav else errmsg = 'Error in rascnv_run: test ntr >= itc + ntc - 3 FAILED' errflg = 1 From 28650fbd76e01858a81889be2436d06b8ec8d5a3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 1 Jul 2021 10:52:07 -0600 Subject: [PATCH 157/165] Remove old comment from physics/m_micro.F90, revert whitespace changes in physics/module_mp_thompson.F90 --- physics/m_micro.F90 | 6 ------ physics/module_mp_thompson.F90 | 4 ++-- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 53ba82392..5b4a5f994 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -181,9 +181,6 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i real (kind=kind_phys), dimension(:,0:),intent(in):: prsi_i, phii -! GJF* These variables are conditionally allocated depending on whether the -! Morrison-Gettelman microphysics is used, so they must be declared -! using assumed shape. real (kind=kind_phys), dimension(:,:), intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & @@ -210,9 +207,6 @@ subroutine m_micro_run( im, lm, flipv, dt_i & integer, dimension(:), intent(inout):: KCBL real (kind=kind_phys),dimension(:,:),intent(inout):: q_io, t_io, & & ncpl_io,ncpi_io,CLLS_io -! GJF* These variables are conditionally allocated depending on whether the -! Morrison-Gettelman microphysics is used, so they must be declared -! using assumed shape. real (kind=kind_phys),dimension(:,:),intent(inout):: rnw_io,snw_io,& & ncpr_io, ncps_io, & & qgl_io, ncgl_io diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index bf3685076..69aaef58c 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1069,8 +1069,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & !..Local variables REAL, DIMENSION(kts:kte):: & - qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ !..Extended diagnostics, single column arrays REAL, DIMENSION(:), ALLOCATABLE:: & From 41cbdc25b4f343f7a40176ce4d8c2e1606401c49 Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Fri, 2 Jul 2021 12:29:28 +0000 Subject: [PATCH 158/165] fix the conflict --- physics/GFS_PBL_generic.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index cfa9b2df5..c8c514757 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -317,7 +317,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, & dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, & dq3dt_ozone, rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, hefac, & + dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) use machine, only : kind_phys From 5c0ea2da1f431674916e3679df977a687a823f2e Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 2 Jul 2021 12:05:50 -0600 Subject: [PATCH 159/165] Comment out extended diagnostics vts1, txri, txrc --- physics/module_mp_thompson.F90 | 187 ++++++++++++++++----------------- physics/mp_thompson.F90 | 118 +++++++++++---------- 2 files changed, 153 insertions(+), 152 deletions(-) diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 69aaef58c..b1301d744 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -991,7 +991,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & errmsg, errflg, & ! Extended diagnostics, array pointers ! only associated if ext_diag flag is .true. - ext_diag, vts1, prw_vcdc, & + ext_diag, & + !vts1, txri, txrc, & + prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & tpri_ide_s, tprs_ide, tprs_sde_d, & tprs_sde_s, tprg_gde_d, & @@ -1001,10 +1003,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprr_rci, tprg_rcg, & tprw_vcd_c, tprw_vcd_e, tprr_sml, & tprr_gml, tprr_rcg, & - tprr_rcs, tprv_rev, txri, & - txrc, tten3, qvten3, qrten3, qsten3, & - qgten3, qiten3, niten3, nrten3, ncten3, & - qcten3) + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3) implicit none @@ -1052,7 +1053,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. LOGICAL, INTENT (IN) :: ext_diag REAL, DIMENSION(:,:,:), INTENT(INOUT):: & - vts1, prw_vcdc, & + !vts1, txri, txrc, & + prw_vcdc, & prw_vcde, tpri_inu, tpri_ide_d, & tpri_ide_s, tprs_ide, & tprs_sde_d, tprs_sde_s, tprg_gde_d, & @@ -1062,10 +1064,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprr_rci, tprg_rcg, & tprw_vcd_c, tprw_vcd_e, tprr_sml, & tprr_gml, tprr_rcg, & - tprr_rcs, tprv_rev, txri, & - txrc, tten3, qvten3, qrten3, qsten3, & - qgten3, qiten3, niten3, nrten3, ncten3, & - qcten3 + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3 !..Local variables REAL, DIMENSION(kts:kte):: & @@ -1074,7 +1075,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & t1d, p1d, w1d, dz1d, rho, dBZ !..Extended diagnostics, single column arrays REAL, DIMENSION(:), ALLOCATABLE:: & - vtsk1, prw_vcdc1, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & @@ -1084,10 +1086,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprr_rci1, tprg_rcg1, & tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, txri1, & - txrc1, tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, & - qcten1 + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) @@ -1176,8 +1177,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & end if end if test_only_once + ! These must be alwyas allocated + !allocate (vtsk1(kts:kte)) + !allocate (txri1(kts:kte)) + !allocate (txrc1(kts:kte)) allocate_extended_diagnostics: if (ext_diag) then - allocate (vtsk1(kts:kte)) allocate (prw_vcdc1(kts:kte)) allocate (prw_vcde1(kts:kte)) allocate (tpri_inu1(kts:kte)) @@ -1205,8 +1209,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & allocate (tprr_rcg1(kts:kte)) allocate (tprr_rcs1(kts:kte)) allocate (tprv_rev1(kts:kte)) - allocate (txri1(kts:kte)) - allocate (txrc1(kts:kte)) allocate (tten1(kts:kte)) allocate (qvten1(kts:kte)) allocate (qrten1(kts:kte)) @@ -1217,11 +1219,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & allocate (nrten1(kts:kte)) allocate (ncten1(kts:kte)) allocate (qcten1(kts:kte)) - else - ! These must be allocated always - allocate (vtsk1(kts:kte)) - allocate (txri1(kts:kte)) - allocate (txrc1(kts:kte)) end if allocate_extended_diagnostics !+---+ @@ -1334,52 +1331,48 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + ! These arrays are always allocated and must be initialized + !vtsk1(k) = 0. + !txrc1(k) = 0. + !txri1(k) = 0. initialize_extended_diagnostics: if (ext_diag) then - vtsk1 = 0. - prw_vcdc1 = 0. - prw_vcde1 = 0. - tpri_inu1 = 0. - tpri_ide1_d = 0. - tpri_ide1_s = 0. - tprs_ide1 = 0. - tprs_sde1_d = 0. - tprs_sde1_s = 0. - tprg_gde1_d = 0. - tprg_gde1_s = 0. - tpri_iha1 = 0. - tpri_wfz1 = 0. - tpri_rfz1 = 0. - tprg_rfz1 = 0. - tprs_scw1 = 0. - tprg_scw1 = 0. - tprg_rcs1 = 0. - tprs_rcs1 = 0. - tprr_rci1 = 0. - tprg_rcg1 = 0. - tprw_vcd1_c = 0. - tprw_vcd1_e = 0. - tprr_sml1 = 0. - tprr_gml1 = 0. - tprr_rcg1 = 0. - tprr_rcs1 = 0. - tprv_rev1 = 0. - txri1 = 0. - txrc1 = 0. - tten1 = 0. - qvten1 = 0. - qrten1 = 0. - qsten1 = 0. - qgten1 = 0. - qiten1 = 0. - niten1 = 0. - nrten1 = 0. - ncten1 = 0. - qcten1 = 0. - else - ! These arrays are always allocated and must be initialized - vtsk1(k) = 0. - txrc1(k) = 0. - txri1(k) = 0. + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprs_scw1(k) = 0. + tprg_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. endif initialize_extended_diagnostics enddo if (is_aerosol_aware) then @@ -1405,7 +1398,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & #endif rand1, rand2, rand3, & kts, kte, dt, i, j, & - ext_diag, vtsk1, prw_vcdc1, prw_vcde1, & + ext_diag, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, & tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & @@ -1414,7 +1409,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprg_rcg1, tprw_vcd1_c, & tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & tprr_rcs1, tprv_rev1, & - txri1, txrc1, tten1, qvten1, qrten1, qsten1, & + tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, qcten1) pcp_ra(i,j) = pptrain @@ -1555,7 +1550,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & assign_extended_diagnostics: if (ext_diag) then do k=kts,kte - vts1(i,k,j) = vtsk1(k) + !vts1(i,k,j) = vtsk1(k) + !txri(i,k,j) = txri(i,k,j) + txri1(k) + !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) @@ -1583,8 +1580,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) - txri(i,k,j) = txri(i,k,j) + txri1(k) - txrc(i,k,j) = txrc(i,k,j) + txrc1(k) tten3(i,k,j) = tten3(i,k,j) + tten1(k) qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) @@ -1662,8 +1657,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' ! END DEBUG - GT + ! These are always allocated + !deallocate (vtsk1) + !deallocate (txri1) + !deallocate (txrc1) deallocate_extended_diagnostics: if (ext_diag) then - deallocate (vtsk1) deallocate (prw_vcdc1) deallocate (prw_vcde1) deallocate (tpri_inu1) @@ -1691,8 +1689,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & deallocate (tprr_rcg1) deallocate (tprr_rcs1) deallocate (tprv_rev1) - deallocate (txri1) - deallocate (txrc1) deallocate (tten1) deallocate (qvten1) deallocate (qrten1) @@ -1703,11 +1699,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & deallocate (nrten1) deallocate (ncten1) deallocate (qcten1) - else - ! These are always allocated - deallocate (vtsk1) - deallocate (txri1) - deallocate (txrc1) end if deallocate_extended_diagnostics END SUBROUTINE mp_gt_driver @@ -1784,7 +1775,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & kts, kte, dt, ii, jj, & ! Extended diagnostics, most arrays only ! allocated if ext_diag flag is .true. - ext_diag, vtsk1, prw_vcdc1, prw_vcde1, & + ext_diag, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, & tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & @@ -1793,7 +1786,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprg_rcg1, tprw_vcd1_c, & tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & tprr_rcs1, tprv_rev1, & - txri1, txrc1, tten1, qvten1, qrten1, qsten1, & + tten1, qvten1, qrten1, qsten1, & qgten1, qiten1, niten1, nrten1, ncten1, qcten1) #ifdef MPI @@ -1813,7 +1806,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! Extended diagnostics, most arrays only allocated if ext_diag is true LOGICAL, INTENT(IN) :: ext_diag REAL, DIMENSION(:), INTENT(OUT):: & - vtsk1, prw_vcdc1, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & prw_vcde1, tpri_inu1, tpri_ide1_d, & tpri_ide1_s, tprs_ide1, & tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & @@ -1823,10 +1817,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprr_rci1, tprg_rcg1, & tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & tprr_gml1, tprr_rcg1, & - tprr_rcs1, tprv_rev1, txri1, & - txrc1, tten1, qvten1, qrten1, qsten1, & - qgten1, qiten1, niten1, nrten1, ncten1, & - qcten1 + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & @@ -2039,7 +2032,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !Diagnostics if (ext_diag) then do k = kts, kte - vtsk1(k) = 0. + !vtsk1(k) = 0. + !txrc1(k) = 0. + !txri1(k) = 0. prw_vcdc1(k) = 0. prw_vcde1(k) = 0. tpri_inu1(k) = 0. @@ -2067,8 +2062,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tprr_rcg1(k) = 0. tprr_rcs1(k) = 0. tprv_rev1(k) = 0. - txrc1(k) = 0. - txri1(k) = 0. tten1(k) = 0. qvten1(k) = 0. qrten1(k) = 0. @@ -3777,7 +3770,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nstep = 0 do k = kte, kts, -1 vts = 0. - vtsk1(k)=0. + !vtsk1(k)=0. if (rs(k).gt. R1) then xDs = smoc(k) / smob(k) @@ -3796,14 +3789,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) vtsk(k) = vts*SR + (1.-SR)*vtrk(k) - vtsk1(k)=vtsk(k) + !vtsk1(k)=vtsk(k) else vtsk(k) = vts*vts_boost(k) - vtsk1(k)=vtsk(k) + !vtsk1(k)=vtsk(k) endif else vtsk(k) = vtsk(k+1) - vtsk1(k)=0 + !vtsk1(k)=0 endif if (vtsk(k) .gt. 1.E-3) then @@ -4002,7 +3995,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) !diag - txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) + !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) endif xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) @@ -4015,7 +4008,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ncten(k) = ncten(k) - xnc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) !diag - txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT + !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT endif enddo endif diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 9548d0920..6fb039b9d 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -22,7 +22,7 @@ module mp_thompson logical :: is_initialized = .False. - integer, parameter :: ext_ndiag3d = 40 + integer, parameter :: ext_ndiag3d = 37 contains @@ -446,7 +446,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! Pointer arrays for extended diagnostics - real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() + !real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() + !real(kind_phys), dimension(:,:,:), pointer :: txri => null() + !real(kind_phys), dimension(:,:,:), pointer :: txrc => null() real(kind_phys), dimension(:,:,:), pointer :: prw_vcdc => null() real(kind_phys), dimension(:,:,:), pointer :: prw_vcde => null() real(kind_phys), dimension(:,:,:), pointer :: tpri_inu => null() @@ -474,8 +476,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg => null() real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs => null() real(kind_phys), dimension(:,:,:), pointer :: tprv_rev => null() - real(kind_phys), dimension(:,:,:), pointer :: txri => null() - real(kind_phys), dimension(:,:,:), pointer :: txrc => null() real(kind_phys), dimension(:,:,:), pointer :: tten3 => null() real(kind_phys), dimension(:,:,:), pointer :: qvten3 => null() real(kind_phys), dimension(:,:,:), pointer :: qrten3 => null() @@ -626,46 +626,46 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & if (reset_diag3d) then diag3d = 0.0 end if - vts1 => diag3d(:,:,1:1) - prw_vcdc => diag3d(:,:,2:2) - prw_vcde => diag3d(:,:,3:3) - tpri_inu => diag3d(:,:,4:4) - tpri_ide_d => diag3d(:,:,5:5) - tpri_ide_s => diag3d(:,:,6:6) - tprs_ide => diag3d(:,:,7:7) - tprs_sde_d => diag3d(:,:,8:8) - tprs_sde_s => diag3d(:,:,9:9) - tprg_gde_d => diag3d(:,:,10:10) - tprg_gde_s => diag3d(:,:,11:11) - tpri_iha => diag3d(:,:,12:12) - tpri_wfz => diag3d(:,:,13:13) - tpri_rfz => diag3d(:,:,14:14) - tprg_rfz => diag3d(:,:,15:15) - tprs_scw => diag3d(:,:,16:16) - tprg_scw => diag3d(:,:,17:17) - tprg_rcs => diag3d(:,:,18:18) - tprs_rcs => diag3d(:,:,19:19) - tprr_rci => diag3d(:,:,20:20) - tprg_rcg => diag3d(:,:,21:21) - tprw_vcd_c => diag3d(:,:,22:22) - tprw_vcd_e => diag3d(:,:,23:23) - tprr_sml => diag3d(:,:,24:24) - tprr_gml => diag3d(:,:,25:25) - tprr_rcg => diag3d(:,:,26:26) - tprr_rcs => diag3d(:,:,27:27) - tprv_rev => diag3d(:,:,28:28) - txri => diag3d(:,:,29:29) - txrc => diag3d(:,:,30:30) - tten3 => diag3d(:,:,31:31) - qvten3 => diag3d(:,:,32:32) - qrten3 => diag3d(:,:,33:33) - qsten3 => diag3d(:,:,34:34) - qgten3 => diag3d(:,:,35:35) - qiten3 => diag3d(:,:,36:36) - niten3 => diag3d(:,:,37:37) - nrten3 => diag3d(:,:,38:38) - ncten3 => diag3d(:,:,39:39) - qcten3 => diag3d(:,:,40:40) + !vts1 => diag3d(:,:,X:X) + !txri => diag3d(:,:,X:X) + !txrc => diag3d(:,:,X:X) + prw_vcdc => diag3d(:,:,1:1) + prw_vcde => diag3d(:,:,2:2) + tpri_inu => diag3d(:,:,3:3) + tpri_ide_d => diag3d(:,:,4:4) + tpri_ide_s => diag3d(:,:,5:5) + tprs_ide => diag3d(:,:,6:6) + tprs_sde_d => diag3d(:,:,7:7) + tprs_sde_s => diag3d(:,:,8:8) + tprg_gde_d => diag3d(:,:,9:9) + tprg_gde_s => diag3d(:,:,10:10) + tpri_iha => diag3d(:,:,11:11) + tpri_wfz => diag3d(:,:,12:12) + tpri_rfz => diag3d(:,:,13:13) + tprg_rfz => diag3d(:,:,14:14) + tprs_scw => diag3d(:,:,15:15) + tprg_scw => diag3d(:,:,16:16) + tprg_rcs => diag3d(:,:,17:17) + tprs_rcs => diag3d(:,:,18:18) + tprr_rci => diag3d(:,:,19:19) + tprg_rcg => diag3d(:,:,20:20) + tprw_vcd_c => diag3d(:,:,21:21) + tprw_vcd_e => diag3d(:,:,22:22) + tprr_sml => diag3d(:,:,23:23) + tprr_gml => diag3d(:,:,24:24) + tprr_rcg => diag3d(:,:,25:25) + tprr_rcs => diag3d(:,:,26:26) + tprv_rev => diag3d(:,:,27:27) + tten3 => diag3d(:,:,28:28) + qvten3 => diag3d(:,:,29:29) + qrten3 => diag3d(:,:,30:30) + qsten3 => diag3d(:,:,31:31) + qgten3 => diag3d(:,:,32:32) + qiten3 => diag3d(:,:,33:33) + niten3 => diag3d(:,:,34:34) + nrten3 => diag3d(:,:,35:35) + ncten3 => diag3d(:,:,36:36) + qcten3 => diag3d(:,:,37:37) end if set_extended_diagnostic_pointers !> - Call mp_gt_driver() with or without aerosols @@ -692,7 +692,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics - ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & tprs_sde_d=tprs_sde_d, & @@ -704,7 +706,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + tprv_rev=tprv_rev, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & qcten3=qcten3) @@ -729,7 +731,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics - ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & tprs_sde_d=tprs_sde_d, & @@ -741,7 +745,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + tprv_rev=tprv_rev, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & qcten3=qcten3) @@ -768,7 +772,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics - ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & tprs_sde_d=tprs_sde_d, & @@ -780,7 +786,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + tprv_rev=tprv_rev, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & qcten3=qcten3) @@ -804,7 +810,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & ! Extended diagnostics - ext_diag=ext_diag, vts1=vts1, prw_vcdc=prw_vcdc, & + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & tprs_sde_d=tprs_sde_d, & @@ -816,7 +824,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & - tprv_rev=tprv_rev, txri=txri, txrc=txrc, tten3=tten3, & + tprv_rev=tprv_rev, tten3=tten3, & qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & qcten3=qcten3) @@ -863,7 +871,9 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & end if unset_extended_diagnostic_pointers: if (ext_diag) then - vts1 => null() + !vts1 => null() + !txri => null() + !txrc => null() prw_vcdc => null() prw_vcde => null() tpri_inu => null() @@ -891,8 +901,6 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & tprr_rcg => null() tprr_rcs => null() tprv_rev => null() - txri => null() - txrc => null() tten3 => null() qvten3 => null() qrten3 => null() From f38d9a16f171561a726dd7421bc3e2404466e0f8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 2 Jul 2021 17:40:58 -0600 Subject: [PATCH 160/165] Yet another index-related bugfix in physics/m_micro.F90 --- physics/m_micro.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 5b4a5f994..f9b793239 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -436,7 +436,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & END DO END DO DO K=0, LM - ll = lm-k+1 + ll = lm-k DO I = 1,IM PLE(i,k) = prsi_i(i,ll) * 0.01_kp ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg From 0808096fa2426fe5003690a69f4d1618b679eb9a Mon Sep 17 00:00:00 2001 From: "Jongil.Han" Date: Sat, 3 Jul 2021 03:08:18 +0000 Subject: [PATCH 161/165] update czilc --- physics/sfc_diff.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0cd373b87..0941b1144 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -260,7 +260,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) ! czilc = 10.0_kp ** (- 4.0_kp * z0max) ! Trier et al. (2011,WAF) - czilc = min(czilc, 0.8_kp) + czilc = max(min(czilc, 0.8_kp), 0.08_kp) tem1 = 1.0_kp - sigmaf(i) czilc = czilc * tem1 * tem1 ztmax_lnd(i) = z0max * exp( - czilc * ca @@ -323,7 +323,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) ! czilc = 10.0_kp ** (- 4.0_kp * z0max) - czilc = min(czilc, 0.8_kp) + czilc = max(min(czilc, 0.8_kp), 0.08_kp) tem1 = 1.0_kp - sigmaf(i) czilc = czilc * tem1 * tem1 ztmax_ice(i) = z0max * exp( - czilc * ca From 69b8c2ec39c7deaaa7a6fdc076830c26a1a80ab6 Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 19 Jul 2021 21:17:58 +0000 Subject: [PATCH 162/165] Revert unintended changes after merge --- physics/GFS_MP_generic.F90 | 2 +- physics/GFS_PBL_generic.F90 | 2 +- physics/GFS_SCNV_generic.F90 | 5 ++--- physics/GFS_SCNV_generic.meta | 18 +++++------------- physics/GFS_suite_interstitial.F90 | 2 +- physics/GFS_suite_interstitial.meta | 9 --------- 6 files changed, 10 insertions(+), 28 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 6967ad80c..239aded39 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -84,7 +84,7 @@ end subroutine GFS_MP_generic_post_init !! !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ - subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & + subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, con_g, dtf, frain, rainc, & rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, snow, graupel, save_t, save_q, rain0, ice0, snow0,& graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp, totprcp, totice, & diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 6bd385eb5..63e622204 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -335,7 +335,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, & rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, hefac, & + dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) use machine, only : kind_phys diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index 88f7fc8c7..2440d9bc7 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -92,7 +92,7 @@ end subroutine GFS_SCNV_generic_post_finalize !! \htmlinclude GFS_SCNV_generic_post_run.html !! subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & - frain, gu0, gv0, gt0, gq0, save_u, save_v, save_t, save_q, dqdti, & + frain, gu0, gv0, gt0, gq0, save_u, save_v, save_t, save_q, & clw, shcnvcw, rain1, npdf3d, num_p3d, ncnvcld3d, cnvc, cnvw, nsamftrac, & rainc, cnvprcp, cnvprcpb, cnvw_phy_f3d, cnvc_phy_f3d, & dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -107,14 +107,13 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, cplchm, flag_for_scnv_generic_tend + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 039ef42e6..92b732ba9 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -348,14 +348,6 @@ type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [frain] standard_name = dynamics_to_physics_timestep_ratio long_name = ratio of dynamics timestep to physics timestep @@ -437,11 +429,11 @@ kind = kind_phys intent = in optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = various + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_cumulative_change_processes) type = real kind = kind_phys intent = inout diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 8fc428ffc..6bc702216 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -702,7 +702,7 @@ end subroutine GFS_suite_interstitial_4_finalize subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, dqdti, ldiag3d, & + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index e46007d97..fe13b3452 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1981,15 +1981,6 @@ kind = kind_phys intent = inout optional = F -[dqdti] - standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection - long_name = instantaneous moisture tendency due to convection - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [dtidx] standard_name = cumulative_change_of_state_variables_outer_index long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index From 8474f91607f36dbe9f47e43b0410f35f37642d5b Mon Sep 17 00:00:00 2001 From: "samuel.trahan" Date: Mon, 19 Jul 2021 21:24:31 +0000 Subject: [PATCH 163/165] Revert CODEOWNERS to community version --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index b6c597371..0d5230f89 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @DomHeinzeller +* @climbfuji @llpcarson @grantfirl @JulieSchramm # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 0e0b7f1e888cc250000f051252c41476859d7de3 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 21 Jul 2021 14:02:45 -0600 Subject: [PATCH 164/165] Revert change to CODEOWNERS --- CODEOWNERS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CODEOWNERS b/CODEOWNERS index 0d5230f89..b6c597371 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -3,7 +3,7 @@ # These owners will be the default owners for everything in the repo. #* @defunkt -* @climbfuji @llpcarson @grantfirl @JulieSchramm +* @DomHeinzeller # Order is important. The last matching pattern has the most precedence. # So if a pull request only touches javascript files, only these owners From 638b159989538b7c7af2c817b7d134434bb8895c Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 23 Jul 2021 17:29:52 -0600 Subject: [PATCH 165/165] Fix b4b differences for GSD v0 (RUC LSM, tiice) --- physics/sfc_drv_ruc.F90 | 20 +++++++++++--------- physics/sfc_drv_ruc.meta | 2 +- 2 files changed, 12 insertions(+), 10 deletions(-) diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f313f2fba..f20b51141 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -99,7 +99,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! --- out real (kind=kind_phys), dimension(:), intent(out) :: zs real (kind=kind_phys), dimension(:), intent(inout) :: sfalb_lnd_bck - real (kind=kind_phys), dimension(:,:), intent(out) :: tsice + real (kind=kind_phys), dimension(:,:), intent(inout) :: tsice real (kind=kind_phys), dimension(:), intent(out) :: semisbase real (kind=kind_phys), dimension(:), intent(out) :: pores, resid @@ -221,16 +221,17 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & enddo ! i - call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) + call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tsfc_lnd, tsfc_wat, tg3, & ! in - zs, dzs, smc, slc, stc, & ! in - sh2o, smfrkeep, tslb, smois, & ! out - wetness, errmsg, errflg) + call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) + if (.not.flag_restart) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) ! - at initial time set sea ice T (tsice) @@ -238,6 +239,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & tsice (i,k) = tslb(i,k) enddo enddo ! i + endif ! .not. restart !-- end of initialization diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 1e6d38fc5..cf37670fe 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -531,7 +531,7 @@ dimensions = (horizontal_dimension,ice_vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [pores] standard_name = maximum_soil_moisture_content_for_land_surface_model