From f94cc61050e504279e29d22d0ef2b248be8e3be7 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 31 Aug 2020 00:32:48 +0000 Subject: [PATCH 01/57] 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 02/57] 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 03/57] 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 04/57] 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 05/57] 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 06/57] 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 07/57] 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 08/57] 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 09/57] 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 10/57] 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 11/57] 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 12/57] 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 13/57] 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 14/57] 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 a0daf0c3bfcadd575eb03b94016f5a94556e758f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 12 Nov 2020 15:52:41 +0000 Subject: [PATCH 15/57] 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 16/57] 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 17/57] 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 18/57] 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 19/57] 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 20/57] 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 21/57] 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 22/57] 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 23/57] 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 24/57] 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 25/57] 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 26/57] 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 27/57] 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 28/57] 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 29/57] 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 30/57] 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 31/57] 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 32/57] 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 33/57] 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 34/57] 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 35/57] 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 9393e61b7b00959bcc1b3242374f94c7d5029d4f Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 27 Apr 2021 21:10:38 -0400 Subject: [PATCH 36/57] 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 c54012c35635f40898117111e82f50a41a754a2e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Thu, 29 Apr 2021 09:56:13 -0400 Subject: [PATCH 37/57] 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 38/57] 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 d4d90c9e86509b84a21f3ce0bda6c3c38a4bd57c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 4 May 2021 19:04:20 -0400 Subject: [PATCH 39/57] 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 40/57] 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 04b562461895b60b3e4b5761ec1ab57d891f1d5a Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Mon, 10 May 2021 20:35:15 -0400 Subject: [PATCH 41/57] 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 42/57] 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 43/57] 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 71d019c934978921f575b8ef2e9059a3b4457775 Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Fri, 14 May 2021 21:13:04 -0400 Subject: [PATCH 44/57] 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 45/57] 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 d642ecfa40b4c539339bcc8b3e001fc69059d1ff Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 26 May 2021 20:01:46 -0400 Subject: [PATCH 46/57] 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 466d4b4d034b8a57fed906219bea1be80c7fe38e Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 8 Jun 2021 19:18:54 +0000 Subject: [PATCH 47/57] 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 48/57] 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 49/57] 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 50/57] 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 51/57] 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 d77e916c90f8cfcfc9a25dfd1e86cf83e6c7677c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Wed, 9 Jun 2021 23:58:37 +0000 Subject: [PATCH 52/57] 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 6910dde33c12192f1c9b884b88ccf1b3bff4c16c Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 15 Jun 2021 13:50:29 +0000 Subject: [PATCH 53/57] 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 54/57] 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 55/57] 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 0a6f3c1b0841a2881bcc93c00a29cfc6fec44edf Mon Sep 17 00:00:00 2001 From: grantfirl Date: Fri, 25 Jun 2021 13:55:18 -0600 Subject: [PATCH 56/57] 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 fe5f2fd31074a84486abc874d427330bca08f8cd Mon Sep 17 00:00:00 2001 From: "Shrinivas.Moorthi" Date: Tue, 29 Jun 2021 20:23:00 -0400 Subject: [PATCH 57/57] 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