From e48c99cea2dc1029cedd6d5b40d8ab83f3986a31 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 20 Aug 2019 11:40:17 -0600 Subject: [PATCH 01/36] initial addition of CCPP metadata for NoahMP --- physics/module_sf_noahmp_glacier.f90 | 2988 ++++++++++ physics/module_sf_noahmplsm.f90 | 8197 ++++++++++++++++++++++++++ physics/module_wrf_utl.f90 | 50 + physics/noahmp_tables.f90 | 955 +++ physics/sfc_noahmp_drv.f | 1142 ++++ physics/sfc_noahmp_drv.meta | 1069 ++++ 6 files changed, 14401 insertions(+) create mode 100755 physics/module_sf_noahmp_glacier.f90 create mode 100755 physics/module_sf_noahmplsm.f90 create mode 100755 physics/module_wrf_utl.f90 create mode 100755 physics/noahmp_tables.f90 create mode 100755 physics/sfc_noahmp_drv.f create mode 100644 physics/sfc_noahmp_drv.meta diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 new file mode 100755 index 000000000..a26e108e4 --- /dev/null +++ b/physics/module_sf_noahmp_glacier.f90 @@ -0,0 +1,2988 @@ +module noahmp_glacier_globals + + implicit none + +! ================================================================================================== +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + +! =====================================options for different schemes================================ +! options for dynamic vegetation: +! 1 -> off (use table lai; use fveg = shdfac from input) +! 2 -> on (together with opt_crs = 1) +! 3 -> off (use table lai; calculate fveg) +! 4 -> off (use table lai; use maximum vegetation fraction) + + integer :: dveg != 2 ! + +! options for canopy stomatal resistance +! 1-> ball-berry; 2->jarvis + + integer :: opt_crs != 1 !(must 1 when dveg = 2) + +! options for soil moisture factor for stomatal resistance +! 1-> noah (soil moisture) +! 2-> clm (matric potential) +! 3-> ssib (matric potential) + + integer :: opt_btr != 1 !(suggested 1) + +! options for runoff and groundwater +! 1 -> topmodel with groundwater (niu et al. 2007 jgr) ; +! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; +! 3 -> original surface and subsurface runoff (free drainage) +! 4 -> bats surface and subsurface runoff (free drainage) + + integer :: opt_run != 1 !(suggested 1) + +! options for surface layer drag coeff (ch & cm) +! 1->m-o ; 2->original noah (chen97); 3->myj consistent; 4->ysu consistent. + + integer :: opt_sfc != 1 !(1 or 2 or 3 or 4) + +! options for supercooled liquid water (or ice fraction) +! 1-> no iteration (niu and yang, 2006 jhm); 2: koren's iteration + + integer :: opt_frz != 1 !(1 or 2) + +! options for frozen soil permeability +! 1 -> linear effects, more permeable (niu and yang, 2006, jhm) +! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_inf != 1 !(suggested 1) + +! options for radiation transfer +! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) +! 2 -> two-stream applied to grid-cell (gap = 0) +! 3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_rad != 1 !(suggested 1) + +! options for ground snow surface albedo +! 1-> bats; 2 -> class + + integer :: opt_alb != 2 !(suggested 2) + +! options for partitioning precipitation into rainfall & snowfall +! 1 -> jordan (1991); 2 -> bats: when sfctmp sfctmp zero heat flux from bottom (zbot and tbot not used) +! 2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_tbot != 2 !(suggested 2) + +! options for snow/soil temperature time scheme (only layer 1) +! 1 -> semi-implicit; 2 -> full implicit (original noah) + + integer :: opt_stc != 1 !(suggested 1) + +! adjustable parameters for snow processes + + real, parameter :: z0sno = 0.002 !snow surface roughness length (m) (0.002) + real, parameter :: ssi = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + real, parameter :: swemx = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + +!------------------------------------------------------------------------------------------! +end module noahmp_glacier_globals +!------------------------------------------------------------------------------------------! + +module noahmp_glacier_routines + use noahmp_glacier_globals + use module_wrf_utl + implicit none + + public :: noahmp_options_glacier + public :: noahmp_glacier + + private :: atm_glacier + private :: energy_glacier + private :: thermoprop_glacier + private :: csnow_glacier + private :: radiation_glacier + private :: snow_age_glacier + private :: snowalb_bats_glacier + private :: snowalb_class_glacier + private :: glacier_flux + private :: sfcdif1_glacier + private :: tsnosoi_glacier + private :: hrt_glacier + private :: hstep_glacier + private :: rosr12_glacier + private :: phasechange_glacier + + private :: water_glacier + private :: snowwater_glacier + private :: snowfall_glacier + private :: combine_glacier + private :: divide_glacier + private :: combo_glacier + private :: compact_glacier + private :: snowh2o_glacier + + private :: error_glacier + +contains +! +! ================================================================================================== + + subroutine noahmp_glacier (& + iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related + sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing + prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : + sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : + tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : + fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : + qsnbot ,ponding ,ponding1,ponding2,t2m ,q2e , & ! out : + emissi, fpice ,ch2b , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! modified to glacier: michael barlage, june 2012 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: zlvl !reference height (m) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: albedo !surface albedo [-] + real , intent(out) :: qsnbot !snowmelt [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: t2m !2-m air temperature over bare ground part [k] + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: fpice + real , intent(out) :: ch2b + real , intent(out) :: esnow + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: rhoair !density air (kg/m3) + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: qmelt !internal pack melt + real :: swdown !downward solar [w/m2] + real :: beg_wb !beginning water for error check + real :: zbot = -8.0 + + character*256 message + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai ,swdown ) + + beg_wb = sneqv + +! snow/soil layer thickness (m); interface depth: zsnso < 0; layer thickness dzsnso > 0 + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zlvl , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + + sice = max(0.0, smc - sh2o) + sneqvo = sneqv + + qvap = max( fgev/lathea, 0.) ! positive part of fgev [mm/s] > 0 + qdew = abs( min(fgev/lathea, 0.)) ! negative part of fgev [mm/s] > 0 + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) + +! if(maxval(sice) < 0.0001) then +! write(message,*) "glacier has melted at:",iloc,jloc," are you sure this should be a glacier point?" +! call wrf_debug(10,trim(message)) +! end if + +! water and energy balance check + + call error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_glacier +! ================================================================================================== + subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai , & + swdown ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + +!locals + + real :: pair !atm bottom level pressure (pa) +! -------------------------------------------------------------------------------------------------- + + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) +! qair = q2 / (1.0+q2) ! mixing ratio to specific humidity [kg/kg] + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + end subroutine atm_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zref , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + +! -------------------------------------------------------------------------------------------------- +! -------------------------------------------------------------------------------------------------- +! use noahmp_veg_parameters +! use noahmp_rad_parameters +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , intent(in) :: zbot !depth for tbot [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + +! input & output + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !snow aging factor + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: ch2b !sensible heat conductance, canopy air to zlvl air (m/s) + + +! local + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: rsurf !ground surface resistance (s/m) + real :: zpd !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: gamma !psychrometric constant (pa/k) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! --------------------------------------------------------------------------------------------------- + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! roughness length and displacement height + + z0mg = z0sno + zpd = snowh + + zlvl = zpd + zref + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground + + call radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out + +! vegetation and ground emissivity + + emg = 0.98 + +! soil surface resistance for ground evap. + + rhsur = 1.0 + rsurf = 1.0 + +! set psychrometric constant + + lathea = hsub + gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and energy fluxes + + call glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0mg , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tg ,qsfc , & !inout + fira ,fsh ,fgev ,ssoil , & !out + t2m ,q2e ,ch2b) !out + +!energy balance at surface: sag=(irb+shb+evb+ghb) + + fire = lwdn + fira + + if(fire <=0.) call wrf_error_fatal("stop in noah-mp: emitted longwave <0") + + ! compute a net emissivity + emissi = emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + +! 3l snow & 4l soil temperatures + + call tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) tg = tfrz + end if + +! energy released or consumed by snow & frozen soil + + call phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy_glacier +! ================================================================================================== + subroutine thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real , intent(in) :: snowh !snow height [m] + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz, iz2 + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real :: zmid !mid-point soil depth +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties (using noah glacial ice approximations) + + do iz = 1, nsoil + zmid = 0.5 * (dzsnso(iz)) + do iz2 = 1, iz-1 + zmid = zmid + dzsnso(iz2) + end do + hcpct(iz) = 1.e6 * ( 0.8194 + 0.1309*zmid ) + df(iz) = 0.32333 + ( 0.10073 * zmid ) + end do + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow_glacier +!=================================================================================================== + subroutine radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + real, intent(in) :: dt !time step [s] + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: qsnow !snowfall (mm/s) + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + +! local + integer :: ib !number of radiation bands + integer :: nband !number of radiation bands + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + real :: alb !current class albedo + real :: abs !temporary absorbed rad + real :: ref !temporary reflected rad + real :: fsno !snow-cover fraction, = 1 if any snow + real, dimension(1:2) :: albice !albedo land ice: 1=vis, 2=nir + + real,parameter :: mpe = 1.e-6 + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + albsnd = 0.0 + albsni = 0.0 + albice(1) = 0.80 !albedo land ice: 1=vis, 2=nir + albice(2) = 0.55 + +! snow age + + call snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: age even when sun is not present + + if(opt_alb == 1) & + call snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class_glacier(nband,qsnow,dt,alb,albold,albsnd,albsni) + albold = alb + end if + +! zero summed solar fluxes + + sag = 0. + fsa = 0. + fsr = 0. + + fsno = 0.0 + if(sneqv > 0.0) fsno = 1.0 + +! loop over nband wavebands + + do ib = 1, nband + + albsnd(ib) = albice(ib)*(1.-fsno) + albsnd(ib)*fsno + albsni(ib) = albice(ib)*(1.-fsno) + albsni(ib)*fsno + +! solar radiation absorbed by ground surface + + abs = solad(ib)*(1.-albsnd(ib)) + solai(ib)*(1.-albsni(ib)) + sag = sag + abs + fsa = fsa + abs + + ref = solad(ib)*albsnd(ib) + solai(ib)*albsni(ib) + fsr = fsr + ref + + end do + + end subroutine radiation_glacier +! ================================================================================================== + subroutine snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +! inout + real, intent(inout) :: tauss !non-dimensional snow age + +!output + real, intent(out) :: fage !snow age + +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else +! tauss = 0. + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_class_glacier (nband,qsnow,dt,alb,albold,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow*dt,swemx) * (0.84-alb)/(swemx) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class_glacier +! ================================================================================================== + subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0m , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tgb ,qsfc , & !inout + irb ,shb ,evb ,ghb , & !out + t2mb ,q2b ,ehb2) !out + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for glacier. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- +! use module_model_constants +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + real, intent(in) :: emg !ground emissivity + integer, intent(in) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: sfcprs !density air (kg/m3) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture + real, dimension( 1:nsoil), intent(in) :: sh2o !soil liquid water + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + +! input/output + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) + real, intent(out) :: q2b !bare ground heat conductance + real, intent(out) :: ehb2 !sensible heat conductance for diagnostics + + +! local variables + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero + real :: dtg !change in tg, last iteration (k) + integer :: mozsgn !number of times moz changes sign + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: h !temporary sensible heat flux (w/m2) + real :: fv !friction velocity (m/s) + real :: cir !coefficients for ir as function of ts**4 + real :: cgh !coefficients for st as function of ts + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cq2b ! + integer :: iter !iteration index + real :: z0h !roughness length, sensible heat, ground (m) + real :: moz !monin-obukhov stability parameter + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + real :: a !temporary calculation + real :: b !temporary calculation + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + real, dimension( 1:nsoil) :: sice !soil ice + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + niterb = 5 + mpe = 1e-6 + dtg = 0. + mozsgn = 0 + mozold = 0. + h = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + z0h = z0m + +! for now, only allow sfcdif1 until others can be fixed + + call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2) !out + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + sice = smc - sh2o + if(opt_stc == 1) then + if ((maxval(sice) > 0.0 .or. snowh > 0.0) .and. tgb > tfrz) then + tgb = tfrz + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag - (irb+shb+evb) + end if + end if + +! 2m air temperature + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + +! update ch + ch = 1./rahb + + end subroutine glacier_flux +! ================================================================================================== + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat +! ================================================================================================== + + subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + integer, intent(in) :: iter !iteration index + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: mpe !prevents overflow error if division by zero + real, intent(in) :: ur !wind speed (m/s) + +! in & out + real, intent(inout) :: moz !monin-obukhov stability (z/l) + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: mol !monin-obukhov length (m) + real :: tvir !temporary virtual temperature (k) + real :: tmp1,tmp2,tmp3 !temporary calculation + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 + + +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical glacier problem: zlvl <= zpd; model stops', zlvl, zpd + call wrf_error_fatal("stop in noah-mp glacier") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1_glacier +! ================================================================================================== + subroutine tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: zbot !from soil surface (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + +! ---------------------------------------------------------------------- + +! prescribe solar penetration into ice/snow + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = zbot - snowh !from snow surface + +! compute ice temperatures + + call hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,df , & + hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep_glacier (nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + + end subroutine tsnosoi_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & !in + stc ,tbot ,zbot ,df , & !in + hcpct ,ssoil ,phi , & !in + ai ,bi ,ci ,rhsts , & !out + botflx ) !out +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hstep_glacier (nsnow ,nsoil ,isnow ,dt , & !in + ai ,bi ,ci ,rhsts , & !inout + stc ) !inout +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + call rosr12_glacier (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep_glacier +! ================================================================================================== + subroutine rosr12_glacier (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12_glacier +! ---------------------------------------------------------------------- +! ================================================================================================== + subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! inputs/outputs + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + +! outputs + real, intent(out) :: qmelt !snowmelt rate [mm/s] + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! local + + integer :: j,k !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = isnow+1,0 ! all snow layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! all soil layers + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then ! melting + imelt(j) = 1 + endif + if (mliq(j) > 0. .and. stc(j) < tfrz) then ! freezing + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr(1) = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr(1) > 0.) then + xm(1) = heatr(1)*dt/hfus + hm(1) = heatr(1) + imelt(1) = 1 + else + xm(1) = 0. + hm(1) = 0. + imelt(1) = 0 + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr(j) = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr(j)) > 0.) then + stc(j) = stc(j) + fact(j)*heatr(j) + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + if (j > 0) xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + heatr = 0.0 + xm = 0.0 + +! deal with residuals in ice/soil + +! first remove excess heat by reducing temperature of layers + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) < tfrz .and. heatr(j) > 0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (abs(heatr(k)) > heatr(j)) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by increasing temperature of layers (may not be necessary with above loop) + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) > tfrz .and. heatr(j) < -0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (heatr(k) > abs(heatr(j))) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess heat by melting ice + + if (any(stc(1:4) > tfrz) .and. any(mice(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mice(k) > 0. .and. xm(j) > 0.1) then + if (mice(k) > xm(j)) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) - mice(k) + xmf = xmf + hfus * mice(k)/dt + mice(k) = 0.0 + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by freezing liquid of layers (may not be necessary with above loop) + + if (any(stc(1:4) < tfrz) .and. any(mliq(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mliq(k) > 0. .and. xm(j) < -0.1) then + if (mliq(k) > abs(xm(j))) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) + mliq(k) + xmf = xmf - hfus * mliq(k)/dt + mice(k) = wmass0(k) + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + sh2o(j) = max(0.0,min(1.0,sh2o(j))) +! smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + smc(j) = 1.0 + end do + + end subroutine phasechange_glacier +! ================================================================================================== + subroutine water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) !out +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: prcp !precipitation (mm/s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real , intent(inout) :: ponding ![mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: fpice !precipitation frozen fraction + real, intent(out) :: esnow ! + +! local + real :: qrain !rain at ground srf (mm) [+] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real :: snowhin !snow depth increasing rate (m/s) + real :: snoflow !glacier flow [mm/s] + real :: bdfall !density of new snow (mm water/m snow) + real :: replace !replacement water due to sublimation of glacier + real, dimension( 1:nsoil) :: sice_save !soil ice content [m3/m3] + real, dimension( 1:nsoil) :: sh2o_save !soil liquid water content [m3/m3] + integer :: ilev + + +! ---------------------------------------------------------------------- +! initialize + + snoflow = 0. + runsub = 0. + runsrf = 0. + sice_save = sice + sh2o_save = sh2o + +! -------------------------------------------------------------------- +! partition precipitation into rain and snow (from canwater) + +! jordan (1991) + + if(opt_snf == 1 .or. opt_snf == 4) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif +! print*, 'fpice: ',fpice + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb: change to min v3.7 + + qrain = prcp * (1.-fpice) + qsnow = prcp * fpice + snowhin = qsnow/bdfall +! print *, 'qrain, qsnow',qrain,qsnow,qrain*dt,qsnow*dt + +! sublimation, frost, evaporation, and dew + +! qsnsub = 0. +! if (sneqv > 0.) then +! qsnsub = min(qvap, sneqv/dt) +! endif +! qseva = qvap-qsnsub + +! qsnfro = 0. +! if (sneqv > 0.) then +! qsnfro = qdew +! endif +! qsdew = qdew - qsnfro + + qsnsub = qvap ! send total sublimation/frost to snowwater and deal with it there + qsnfro = qdew + esnow = qsnsub*2.83e+6 + + +! print *, 'qvap',qvap,qvap*dt +! print *, 'qsnsub',qsnsub,qsnsub*dt +! print *, 'qseva',qseva,qseva*dt +! print *, 'qsnfro',qsnfro,qsnfro*dt +! print *, 'qdew',qdew,qdew*dt +! print *, 'qsdew',qsdew,qsdew*dt +!print *, 'before snowwater', sneqv,snowh,snice,snliq,sh2o,sice + call snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +!print *, 'after snowwater', sneqv,snowh,snice,snliq,sh2o,sice +!print *, 'ponding', ponding,ponding1,ponding2 + + !ponding: melting water from snow when there is no layer + + runsrf = (ponding+ponding1+ponding2)/dt + + if(isnow == 0) then + runsrf = runsrf + qsnbot + qrain + else + runsrf = runsrf + qsnbot + endif + + + replace = 0.0 + do ilev = 1,nsoil + replace = replace + dzsnso(ilev)*(sice(ilev) - sice_save(ilev) + sh2o(ilev) - sh2o_save(ilev)) + end do + replace = replace * 1000.0 / dt ! convert to [mm/s] + + sice = min(1.0,sice_save) + sh2o = 1.0 - sice +!print *, 'replace', replace + + ! use runsub as a water balancer, snoflow is snow that disappears, replace is + ! water from below that replaces glacier loss + + runsub = snoflow + replace + + end subroutine water_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + + if(isnow < 0) then !when more than one layer + call compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout + + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + call divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + end if + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + + call snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow /= 0) then + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater_glacier +! ================================================================================================== + subroutine snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact_glacier +! ================================================================================================== + subroutine combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + real :: dzmin(3) ! minimum of top snow layer + data dzmin /0.045, 0.05, 0.2/ +! data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + ponding1 = ponding1 + snliq(j) ! isnow will get set to zero below + sneqv = snice(j) ! ponding will get added to ponding from + snowh = dzsnso(j) ! phasechange which should be zero here + snliq(j) = 0.0 ! because there it was only calculated + snice(j) = 0.0 ! for thin snow + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + +! if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit + if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = ponding2 + zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo_glacier (dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine_glacier +! ================================================================================================== + +! ---------------------------------------------------------------------- + subroutine combo_glacier(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo_glacier +! ================================================================================================== + subroutine divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo_glacier (dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer +! if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit + if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo_glacier (dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide_glacier +! ================================================================================================== + subroutine snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !inout + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o_glacier +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: sag + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: sneqv !snow water eqv. [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + + real :: end_wb !water storage at end of a timestep [mm] + real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- + errsw = swdown - (fsa + fsr) + if (errsw > 0.01) then ! w/m2 + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa + write(*,*) "fsr =",fsr + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("radiation budget problem in noahmp glacier") + end if + + erreng = sag-(fira+fsh+fgev+ssoil) + if(erreng > 0.01) then + write(message,*) 'erreng =',erreng + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,5f10.4)')iloc,jloc,sag,fira,fsh,fgev,ssoil + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp glacier") + end if + + end_wb = sneqv + errwat = end_wb-beg_wb-(prcp-edir-runsrf-runsub)*dt + + + end subroutine error_glacier +! ================================================================================================== + + subroutine noahmp_options_glacier(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options_glacier + +end module noahmp_glacier_routines +! ================================================================================================== + +module module_sf_noahmp_glacier + + use noahmp_glacier_routines + use noahmp_glacier_globals + +end module module_sf_noahmp_glacier + diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 new file mode 100755 index 000000000..139c53277 --- /dev/null +++ b/physics/module_sf_noahmplsm.f90 @@ -0,0 +1,8197 @@ +module module_sf_noahmplsm + use module_wrf_utl + + implicit none + + public :: noahmp_options + public :: noahmp_sflx + + private :: atm + private :: phenology + private :: precip_heat + private :: energy + private :: thermoprop + private :: csnow + private :: tdfcnd + private :: radiation + private :: albedo + private :: snow_age + private :: snowalb_bats + private :: snowalb_class + private :: groundalb + private :: twostream + private :: surrad + private :: vege_flux + private :: sfcdif1 + private :: sfcdif2 + private :: stomata + private :: canres + private :: esat + private :: ragrb + private :: bare_flux + private :: tsnosoi + private :: hrt + private :: hstep + private :: rosr12 + private :: phasechange + private :: frh2o + + private :: water + private :: canwater + private :: snowwater + private :: snowfall + private :: combine + private :: divide + private :: combo + private :: compact + private :: snowh2o + private :: soilwater + private :: zwteq + private :: infil + private :: srt + private :: wdfcnd1 + private :: wdfcnd2 + private :: sstep + private :: groundwater + private :: shallowwatertable + + private :: carbon + private :: co2flux +! private :: bvocflux +! private :: ch4flux + + private :: error + +! =====================================options for different schemes================================ +! **recommended + + integer :: dveg ! options for dynamic vegetation: + ! 1 -> off (use table lai; use fveg = shdfac from input) + ! 2 -> on (together with opt_crs = 1) + ! 3 -> off (use table lai; calculate fveg) + ! **4 -> off (use table lai; use maximum vegetation fraction) + ! **5 -> on (use maximum vegetation fraction) + + integer :: opt_crs ! options for canopy stomatal resistance + ! **1 -> ball-berry + ! 2 -> jarvis + + integer :: opt_btr ! options for soil moisture factor for stomatal resistance + ! **1 -> noah (soil moisture) + ! 2 -> clm (matric potential) + ! 3 -> ssib (matric potential) + + integer :: opt_run ! options for runoff and groundwater + ! **1 -> topmodel with groundwater (niu et al. 2007 jgr) ; + ! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; + ! 3 -> original surface and subsurface runoff (free drainage) + ! 4 -> bats surface and subsurface runoff (free drainage) + ! 5 -> miguez-macho&fan groundwater scheme (miguez-macho et al. 2007 jgr; fan et al. 2007 jgr) + ! (needs further testing for public use) + + integer :: opt_sfc ! options for surface layer drag coeff (ch & cm) + ! **1 -> m-o + ! **2 -> original noah (chen97) + ! **3 -> myj consistent; 4->ysu consistent. mb: removed in v3.7 for further testing + + integer :: opt_frz ! options for supercooled liquid water (or ice fraction) + ! **1 -> no iteration (niu and yang, 2006 jhm) + ! 2 -> koren's iteration + + integer :: opt_inf ! options for frozen soil permeability + ! **1 -> linear effects, more permeable (niu and yang, 2006, jhm) + ! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_rad ! options for radiation transfer + ! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! **3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_alb ! options for ground snow surface albedo + ! 1 -> bats + ! **2 -> class + + integer :: opt_snf ! options for partitioning precipitation into rainfall & snowfall + ! **1 -> jordan (1991) + ! 2 -> bats: when sfctmp sfctmp < tfrz + ! 4 -> use wrf microphysics output + + integer :: opt_tbot ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (zbot and tbot not used) + ! **2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_stc ! options for snow/soil temperature time scheme (only layer 1) + ! **1 -> semi-implicit; flux top boundary condition + ! 2 -> full implicit (original noah); temperature top boundary condition + ! 3 -> same as 1, but fsno for ts calculation (generally improves snow; v3.7) + +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) (not used mb: 20140718) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + + integer, private, parameter :: mband = 2 + + type noahmp_parameters ! define a noahmp parameters type + +!------------------------------------------------------------------------------------------! +! from the veg section of mptable.tbl +!------------------------------------------------------------------------------------------! + + logical :: urban_flag + integer :: iswater + integer :: isbarren + integer :: isice + integer :: eblforest + + real :: ch2op !maximum intercepted h2o per unit lai+sai (mm) + real :: dleaf !characteristic leaf dimension (m) + real :: z0mvt !momentum roughness length (m) + real :: hvt !top of canopy (m) + real :: hvb !bottom of canopy (m) + real :: den !tree density (no. of trunks per m2) + real :: rc !tree crown radius (m) + real :: mfsno !snowmelt m parameter () + real :: saim(12) !monthly stem area index, one-sided + real :: laim(12) !monthly leaf area index, one-sided + real :: sla !single-side leaf area per kg [m2/kg] + real :: dilefc !coeficient for leaf stress death [1/s] + real :: dilefw !coeficient for leaf stress death [1/s] + real :: fragr !fraction of growth respiration !original was 0.3 + real :: ltovrc !leaf turnover [1/s] + + real :: c3psn !photosynthetic pathway: 0. = c4, 1. = c3 + real :: kc25 !co2 michaelis-menten constant at 25c (pa) + real :: akc !q10 for kc25 + real :: ko25 !o2 michaelis-menten constant at 25c (pa) + real :: ako !q10 for ko25 + real :: vcmx25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + real :: avcmx !q10 for vcmx25 + real :: bp !minimum leaf conductance (umol/m**2/s) + real :: mp !slope of conductance-to-photosynthesis relationship + real :: qe25 !quantum efficiency at 25c (umol co2 / umol photon) + real :: aqe !q10 for qe25 + real :: rmf25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + real :: rms25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + real :: rmr25 !root maintenance respiration at 25c (umol co2/kg bio/s) + real :: arm !q10 for maintenance respiration + real :: folnmx !foliage nitrogen concentration when f(n)=1 (%) + real :: tmin !minimum temperature for photosynthesis (k) + + real :: xl !leaf/stem orientation index + real :: rhol(mband) !leaf reflectance: 1=vis, 2=nir + real :: rhos(mband) !stem reflectance: 1=vis, 2=nir + real :: taul(mband) !leaf transmittance: 1=vis, 2=nir + real :: taus(mband) !stem transmittance: 1=vis, 2=nir + + real :: mrp !microbial respiration parameter (umol co2 /kg c/ s) + real :: cwpvt !empirical canopy wind parameter + + real :: wrrat !wood to non-wood ratio + real :: wdpool !wood pool (switch 1 or 0) depending on woody or not [-] + real :: tdlef !characteristic t for leaf freezing [k] + + integer :: nroot !number of soil layers with root present + real :: rgl !parameter used in radiation stress function + real :: rsmin !minimum stomatal resistance [s m-1] + real :: hs !parameter used in vapor pressure deficit function + real :: topt !optimum transpiration air temperature [k] + real :: rsmax !maximal stomatal resistance [s m-1] + + real :: slarea + real :: eps(5) + +!------------------------------------------------------------------------------------------! +! from the rad section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: albsat(mband) !saturated soil albedos: 1=vis, 2=nir + real :: albdry(mband) !dry soil albedos: 1=vis, 2=nir + real :: albice(mband) !albedo land ice: 1=vis, 2=nir + real :: alblak(mband) !albedo frozen lakes: 1=vis, 2=nir + real :: omegas(mband) !two-stream parameter omega for snow + real :: betads !two-stream parameter betad for snow + real :: betais !two-stream parameter betad for snow + real :: eg(2) !emissivity + +!------------------------------------------------------------------------------------------! +! from the globals section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: co2 !co2 partial pressure + real :: o2 !o2 partial pressure + real :: timean !gridcell mean topgraphic index (global mean) + real :: fsatmx !maximum surface saturated fraction (global mean) + real :: z0sno !snow surface roughness length (m) (0.002) + real :: ssi !liquid water holding capacity for snowpack (m3/m3) + real :: swemx !new snow mass to fully cover old snow (mm) + +!------------------------------------------------------------------------------------------! +! from the soilparm.tbl tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + real :: bexp !b parameter + real :: smcdry !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used mb: 20140718) + real :: smcwlt !wilting point soil moisture (volumetric) + real :: smcref !reference soil moisture (field capacity) (volumetric) + real :: smcmax !porosity, saturated value of soil moisture (volumetric) + real :: f1 !soil thermal diffusivity/conductivity coef (not used mb: 20140718) + real :: psisat !saturated soil matric potential + real :: dksat !saturated soil hydraulic conductivity + real :: dwsat !saturated soil hydraulic diffusivity + real :: quartz !soil quartz content +!------------------------------------------------------------------------------------------! +! from the genparm.tbl file +!------------------------------------------------------------------------------------------! + real :: slope !slope index (0 - 1) + real :: csoil !vol. soil heat capacity [j/m3/k] + real :: zbot !depth (m) of lower boundary soil temperature + real :: czil !calculate roughness length of heat + + real :: kdt !used in compute maximum infiltration rate (in infil) + real :: frzx !used in compute maximum infiltration rate (in infil) + + end type noahmp_parameters + +contains +! +!== begin noahmp_sflx ============================================================================== + + subroutine noahmp_sflx (parameters, & + iloc , jloc , lat , yearlen , julian , cosz , & ! in : time/space-related + dt , dx , dz8w , nsoil , zsoil , nsnow , & ! in : model configuration + shdfac , shdmax , vegtyp , ice , ist , & ! in : vegetation/soil characteristics + smceq , & ! in : vegetation/soil characteristics + sfctmp , sfcprs , psfc , uu , vv , q2 , & ! in : forcing + qc , soldn , lwdn , & ! in : forcing + prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing + tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing + albold , sneqvo , & ! in/out : + stc , sh2o , smc , tah , eah , fwet , & ! in/out : + canliq , canice , tv , tg , qsfc , qsnow , & ! in/out : + isnow , zsnso , snowh , sneqv , snice , snliq , & ! in/out : + zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out : + stmass , wood , stblcp , fastcp , lai , sai , & ! in/out : + cm , ch , tauss , & ! in/out : + smcwtd ,deeprech , rech , & ! in/out : + z0wrf , & + fsa , fsr , fira , fsh , ssoil , fcev , & ! out : + fgev , fctr , ecan , etran , edir , trad , & ! out : + tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out : + runsrf , runsub , apar , psn , sav , sag , & ! out : + fsno , nee , gpp , npp , fveg , albedo , & ! out : + qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out : + bgap , wgap , chv , chb , emissi , & ! out : + shg , shc , shb , evg , evb , ghv , & ! out : + ghb , irg , irc , irb , tr , evc , & ! out : + chleaf , chuc , chv2 , chb2 , fpice , pahv , & + pahg , pahb , pah , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: dt !time step [sec] + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(inout) :: zlvl !reference height (m) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: foln !foliage nitrogen (%) [1-saturated] + real , intent(in) :: shdfac !green vegetation fraction [0.0-1.0] + integer , intent(in) :: yearlen!number of days in the particular year. + real , intent(in) :: julian !julian day of year (floating point) + real , intent(in) :: lat !latitude (radians) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: dx + real , intent(in) :: shdmax !yearly max vegetation fraction +!jref:end + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: fwet !wetted or snowed fraction of canopy (-) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air tmeperature (k) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !non-dimensional snow age + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: canliq !intercepted liquid water (mm) + real , intent(inout) :: canice !intercepted ice mass (mm) + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: zwt !depth to water table [m] + real , intent(inout) :: wa !water storage in aquifer [mm] + real , intent(inout) :: wt !water in aquifer&saturated soil [mm] + real , intent(inout) :: wslake !lake water storage (can be neg.) (mm) + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real , intent(out) :: z0wrf !combined z0 sent to coupled model + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evap heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real :: ts !surface temperature (k) + real , intent(out) :: ecan !evaporation of intercepted water (mm/s) + real , intent(out) :: etran !transpiration rate (mm/s) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: psn !total photosynthesis (umol co2/m2/s) [+] + real , intent(out) :: apar !photosyn active energy by canopy (w/m2) + real , intent(out) :: sav !solar rad absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: fsno !snow cover fraction on the ground (-) + real , intent(out) :: fveg !green vegetation fraction [0.0-1.0] + real , intent(out) :: albedo !surface albedo [-] + real :: errwat !water error [kg m{-2}] + real , intent(out) :: qsnbot !snowmelt out bottom of pack [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: esnow + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + real, intent(out) :: bgap + real, intent(out) :: wgap + real, intent(out) :: tgv + real, intent(out) :: tgb + real :: q1 + real, intent(out) :: emissi +!jref:end + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: cmc !intercepted water (canice+canliq) (mm) + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: rhoair !density air (kg/m3) +! real, dimension( 1: 5) :: vocflx !voc fluxes [ug c m-2 h-1] + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real :: qprecc !convective precipitation (mm/s) + real :: qprecl !large-scale precipitation (mm/s) + real :: igs !growing season index (0=off, 1=on) + real :: elai !leaf area index, after burying by snow + real :: esai !stem area index, after burying by snow + real :: bevap !soil water evaporation factor (0 - 1) + real, dimension( 1:nsoil) :: btrani !soil water transpiration factor (0 - 1) + real :: btran !soil water transpiration factor (0 - 1) + real :: qin !groundwater recharge [mm/s] + real :: qdis !groundwater discharge [mm/s] + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: totsc !total soil carbon (g/m2) + real :: totlb !total living carbon (g/m2) + real :: t2m !2-meter air temperature (k) + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: swdown !downward solar [w/m2] + real :: qmelt !snowmelt [mm/s] + real :: beg_wb !water storage at begin of a step [mm] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real, intent(out) :: fpice !snow fraction in precipitation + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +!jref:start + real :: fsrv + real :: fsrg + real,intent(out) :: q2v + real,intent(out) :: q2b + real :: q2e + real :: qfx + real,intent(out) :: chv !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb !sensible heat exchange coefficient over bare-ground + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient + real,intent(out) :: chv2 !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb2 !sensible heat exchange coefficient over bare-ground +!jref:end + +! carbon +! inputs + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + +! inputs and outputs : prognostic variables + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon, shallow soil [g/m2] + real , intent(inout) :: lai !leaf area index [-] + real , intent(inout) :: sai !stem area index [-] + +! outputs + real , intent(out) :: nee !net ecosys exchange (g/m2/s co2) + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real :: autors !net ecosystem respiration (g/m2/s c) + real :: heters !organic respiration (g/m2/s c) + real :: troot !root-zone averaged temperature (k) + real :: bdfall !bulk density of new snow (kg/m3) ! mb/an: v3.7 + real :: rain !rain rate (mm/s) ! mb/an: v3.7 + real :: snow !liquid equivalent snow rate (mm/s) ! mb/an: v3.7 + real :: fp ! mb/an: v3.7 + real :: prcp ! mb/an: v3.7 +!more local variables for precip heat mb + real :: qintr !interception rate for rain (mm/s) + real :: qdripr !drip rate for rain (mm/s) + real :: qthror !throughfall for rain (mm/s) + real :: qints !interception (loading) rate for snowfall (mm/s) + real :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real :: qthros !throughfall of snowfall (mm/s) + real :: qrain !rain at ground srf (mm/s) [+] + real :: snowhin !snow depth increasing rate (m/s) + real :: latheav !latent heat vap./sublimation (j/kg) + real :: latheag !latent heat vap./sublimation (j/kg) + logical :: frozen_ground ! used to define latent heat pathway + logical :: frozen_canopy ! used to define latent heat pathway + + ! intent (out) variables need to be assigned a value. these normally get assigned values + ! only if dveg == 2. + nee = 0.0 + npp = 0.0 + gpp = 0.0 + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad ,solai , & + swdown ,bdfall ,rain ,snow ,fp ,fpice , prcp ) + +! snow/soil layer thickness (m) + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! root-zone temperature + + troot = 0. + do iz=1,parameters%nroot + troot = troot + stc(iz)*dzsnso(iz)/(-zsoil(parameters%nroot)) + enddo + +! total water storage for water balance check + + if(ist == 1) then + beg_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + beg_wb = beg_wb + smc(iz) * dzsnso(iz) * 1000. + end do + end if + +! vegetation phenology + + call phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai ,igs) + +!input gvf should be consistent with lai + if(dveg == 1) then + fveg = shdfac + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 2 .or. dveg == 3) then + fveg = 1.-exp(-0.52*(lai+sai)) + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 4 .or. dveg == 5) then + fveg = shdmax + if(fveg <= 0.05) fveg = 0.05 + else + write(*,*) "-------- fatal called in sflx -----------" + call wrf_error_fatal("namelist parameter dveg unknown") + endif + if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0 + if(elai+esai == 0.0) fveg = 0.0 + + call precip_heat(parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap, tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out + emissi ,pah , & + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + + sice(:) = max(0.0, smc(:) - sh2o(:)) + sneqvo = sneqv + + qvap = max( fgev/latheag, 0.) ! positive part of fgev; barlage change to ground v3.6 + qdew = abs( min(fgev/latheag, 0.)) ! negative part of fgev + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in + bdfall ,fp ,rain ,snow , & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2,& + qsnbot ,esnow ) !out + +! write(*,'(a20,10f15.5)') 'sflx:runoff=',runsrf*dt,runsub*dt,edir*dt + +! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + + if (dveg == 2 .or. dveg == 5) then + call carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,lai ,sai ) !out + end if + +! water and energy balance check + + call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in + nsnow ,ist ,errwat ,iloc , jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + +! urban - jref + qfx = etran + ecan + edir + if ( parameters%urban_flag ) then + qsfc = (qfx/rhoair*ch) + qair + q2b = qsfc + end if + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_sflx + +!== begin atm ====================================================================================== + + subroutine atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad , solai , & + swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: qprecc !convective precipitation (mm/s) + real , intent(out) :: qprecl !large-scale precipitation (mm/s) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(out) :: bdfall !!bulk density of snowfall (kg/m3) ajn + real , intent(out) :: rain !rainfall (mm/s) ajn + real , intent(out) :: snow !liquid equivalent snowfall (mm/s) ajn + real , intent(out) :: fp !fraction of area receiving precipitation ajn + real , intent(out) :: fpice !fraction of ice ajn + real , intent(out) :: prcp !total precipitation [mm/s] ! mb/an : v3.7 + +!locals + + real :: pair !atm bottom level pressure (pa) + real :: prcp_frozen !total frozen precipitation [mm/s] ! mb/an : v3.7 + real, parameter :: rho_grpl = 500.0 ! graupel bulk density [kg/m3] ! mb/an : v3.7 + real, parameter :: rho_hail = 917.0 ! hail bulk density [kg/m3] ! mb/an : v3.7 +! -------------------------------------------------------------------------------------------------- + +!jref: seems like pair should be p1000mb?? + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) + + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + prcp = prcpconv + prcpnonc + prcpshcv + +! if(opt_snf == 4) then + qprecc = prcpconv + prcpshcv + qprecl = prcpnonc +! else +! qprecc = 0.10 * prcp ! should be from the atmospheric model +! qprecl = 0.90 * prcp ! should be from the atmospheric model +! end if + +! fractional area that receives precipitation (see, niu et al. 2005) + + fp = 0.0 + if(qprecc + qprecl > 0.) & + fp = (qprecc + qprecl) / (10.*qprecc + qprecl) + +! partition precipitation into rain and snow. moved from canwat mb/an: v3.7 + +! jordan (1991) + + if(opt_snf == 1) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min + if(opt_snf == 4) then + prcp_frozen = prcpsnow + prcpgrpl + prcphail + if(prcpnonc > 0. .and. prcp_frozen > 0.) then + fpice = min(1.0,prcp_frozen/prcp) + fpice = max(0.0,fpice) + bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & + rho_hail*(prcphail/prcp_frozen) + else + fpice = 0.0 + endif + + endif + + rain = prcp * (1.-fpice) + snow = prcp * fpice + + + end subroutine atm + +!== begin phenology ================================================================================ + + subroutine phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai , igs) + +! -------------------------------------------------------------------------------------------------- +! vegetation phenology considering vegeation canopy being buries by snow and evolution in time +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in ) :: vegtyp !vegetation type + real , intent(in ) :: snowh !snow height [m] + real , intent(in ) :: tv !vegetation temperature (k) + real , intent(in ) :: lat !latitude (radians) + integer , intent(in ) :: yearlen!number of days in the particular year + real , intent(in ) :: julian !julian day of year (fractional) ( 0 <= julian < yearlen ) + real , intent(in ) :: troot !root-zone averaged temperature (k) + real , intent(inout) :: lai !lai, unadjusted for burying by snow + real , intent(inout) :: sai !sai, unadjusted for burying by snow + +! outputs + real , intent(out ) :: elai !leaf area index, after burying by snow + real , intent(out ) :: esai !stem area index, after burying by snow + real , intent(out ) :: igs !growing season index (0=off, 1=on) + +! locals + + real :: db !thickness of canopy buried by snow (m) + real :: fb !fraction of canopy buried by snow + real :: snowhc !critical snow depth at which short vege + !is fully covered by snow + + integer :: k !index + integer :: it1,it2 !interpolation months + real :: day !current day of year ( 0 <= day < yearlen ) + real :: wt1,wt2 !interpolation weights + real :: t !current month (1.00, ..., 12.00) +! -------------------------------------------------------------------------------------------------- + + if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then + + if (lat >= 0.) then + ! northern hemisphere + day = julian + else + ! southern hemisphere. day is shifted by 1/2 year. + day = mod ( julian + ( 0.5 * yearlen ) , real(yearlen) ) + endif + + t = 12. * day / real(yearlen) + it1 = t + 0.5 + it2 = it1 + 1 + wt1 = (it1+0.5) - t + wt2 = 1.-wt1 + if (it1 .lt. 1) it1 = 12 + if (it2 .gt. 12) it2 = 1 + + lai = wt1*parameters%laim(it1) + wt2*parameters%laim(it2) + sai = wt1*parameters%saim(it1) + wt2*parameters%saim(it2) + endif + if (sai < 0.05) sai = 0.0 ! mb: sai check, change to 0.05 v3.6 + if (lai < 0.05 .or. sai == 0.0) lai = 0.0 ! mb: lai check + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. ( parameters%urban_flag ) ) then + lai = 0. + sai = 0. + endif + +!buried by snow + + db = min( max(snowh - parameters%hvb,0.), parameters%hvt-parameters%hvb ) + fb = db / max(1.e-06,parameters%hvt-parameters%hvb) + + if(parameters%hvt> 0. .and. parameters%hvt <= 1.0) then !mb: change to 1.0 and 0.2 to reflect + snowhc = parameters%hvt*exp(-snowh/0.2) ! changes to hvt in mptable + fb = min(snowh,snowhc)/snowhc + endif + + elai = lai*(1.-fb) + esai = sai*(1.-fb) + if (esai < 0.05) esai = 0.0 ! mb: esai check, change to 0.05 v3.6 + if (elai < 0.05 .or. esai == 0.0) elai = 0.0 ! mb: lai check + + if (tv .gt. parameters%tmin) then + igs = 1. + else + igs = 0. + endif + + end subroutine phenology + +!== begin precip_heat ============================================================================== + + subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! ------------------------ code history ------------------------------ +! michael barlage: oct 2013 - split canwater to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + integer,intent(in) :: ist !surface type 1-soil; 2-lake + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: bdfall !bulk density of snowfall (kg/m3) + real, intent(in) :: rain !rainfall (mm/s) + real, intent(in) :: snow !snowfall (mm/s) + real, intent(in) :: fp !fraction of the gridcell that receives precipitation + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: sfctmp !model-level temperature (k) + real, intent(in) :: tg !ground temperature (k) + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + +! output + real, intent(out) :: qintr !interception rate for rain (mm/s) + real, intent(out) :: qdripr !drip rate for rain (mm/s) + real, intent(out) :: qthror !throughfall for rain (mm/s) + real, intent(out) :: qints !interception (loading) rate for snowfall (mm/s) + real, intent(out) :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real, intent(out) :: qthros !throughfall of snowfall (mm/s) + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: qrain !rain at ground srf (mm/s) [+] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: snowhin !snow depth increasing rate (m/s) + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) + real, intent(out) :: cmc !intercepted water (mm) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: ft !temperature factor for unloading rate + real :: fv !wind factor for unloading rate + real :: pah_ac !precipitation advected heat - air to canopy (w/m2) + real :: pah_cg !precipitation advected heat - canopy to ground (w/m2) + real :: pah_ag !precipitation advected heat - air to ground (w/m2) + real :: icedrip !canice unloading +! -------------------------------------------------------------------- +! initialization + + qintr = 0. + qdripr = 0. + qthror = 0. + qintr = 0. + qints = 0. + qdrips = 0. + qthros = 0. + pah_ac = 0. + pah_cg = 0. + pah_ag = 0. + pahv = 0. + pahg = 0. + pahb = 0. + qrain = 0.0 + qsnow = 0.0 + snowhin = 0.0 + icedrip = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! average interception and throughfall + + if((elai+ esai).gt.0.) then + qintr = fveg * rain * fp ! interception capability + qintr = min(qintr, (maxliq - canliq)/dt * (1.-exp(-rain*dt/maxliq)) ) + qintr = max(qintr, 0.) + qdripr = fveg * rain - qintr + qthror = (1.-fveg) * rain + canliq=max(0.,canliq+qintr*dt) + else + qintr = 0. + qdripr = 0. + qthror = rain + if(canliq > 0.) then ! for case of canopy getting buried + qdripr = qdripr + canliq/dt + canliq = 0.0 + end if + end if + +! heat transported by liquid water + + pah_ac = fveg * rain * (cwat/1000.0) * (sfctmp - tv) + pah_cg = qdripr * (cwat/1000.0) * (tv - tg) + pah_ag = qthror * (cwat/1000.0) * (sfctmp - tg) +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + if((elai+ esai).gt.0.) then + qints = fveg * snow * fp + qints = min(qints, (maxsno - canice)/dt * (1.-exp(-snow*dt/maxsno)) ) + qints = max(qints, 0.) + ft = max(0.0,(tv - 270.15) / 1.87e5) + fv = sqrt(uu*uu + vv*vv) / 1.56e5 + ! mb: changed below to reflect the rain assumption that all precip gets intercepted + icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt + qdrips = (fveg * snow - qints) + icedrip + qthros = (1.0-fveg) * snow + canice= max(0.,canice + (qints - icedrip)*dt) + else + qints = 0. + qdrips = 0. + qthros = snow + if(canice > 0.) then ! for case of canopy getting buried + qdrips = qdrips + canice/dt + canice = 0.0 + end if + endif +! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints) +! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft) + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! total canopy water + + cmc = canliq + canice + +! heat transported by snow/ice + + pah_ac = pah_ac + fveg * snow * (cice/1000.0) * (sfctmp - tv) + pah_cg = pah_cg + qdrips * (cice/1000.0) * (tv - tg) + pah_ag = pah_ag + qthros * (cice/1000.0) * (sfctmp - tg) + + pahv = pah_ac - pah_cg + pahg = pah_cg + pahb = pah_ag + + if (fveg > 0.0 .and. fveg < 1.0) then + pahg = pahg / fveg ! these will be multiplied by fraction later + pahb = pahb / (1.0-fveg) + elseif (fveg <= 0.0) then + pahb = pahg + pahb ! for case of canopy getting buried + pahg = 0.0 + pahv = 0.0 + elseif (fveg >= 1.0) then + pahb = 0.0 + end if + + pahv = max(pahv,-20.0) ! put some artificial limits here for stability + pahv = min(pahv,20.0) + pahg = max(pahg,-20.0) + pahg = min(pahg,20.0) + pahb = max(pahb,-20.0) + pahb = min(pahb,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! print*, "precip_heat pahv:",pahv +! print*, "precip_heat pahg:",pahg +! print*, "precip_heat pahb:",pahb +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground + + qrain = qdripr + qthror + qsnow = qdrips + qthros + snowhin = qsnow/bdfall + + if (ist == 2 .and. tg > tfrz) then + qsnow = 0. + snowhin = 0. + end if +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat snowhin:",snowhin +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + + + end subroutine precip_heat + +!== begin error ==================================================================================== + + subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & + nsnow ,ist ,errwat, iloc ,jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fcev !canopy evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fctr !transpiration heat flux (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: fveg + real , intent(in) :: sav + real , intent(in) :: sag + real , intent(in) :: fsrv + real , intent(in) :: fsrg + real , intent(in) :: zwt + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: ecan !evaporation of intercepted water (mm/s) + real , intent(in) :: etran !transpiration rate (mm/s) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: canliq !intercepted liquid water (mm) + real , intent(in) :: canice !intercepted ice mass (mm) + real , intent(in) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real , intent(in) :: wa !water storage in aquifer [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + real , intent(out) :: errwat !error in water balance [mm/timestep] + real, intent(in) :: pah !precipitation advected heat - total (w/m2) + real, intent(in) :: pahv !precipitation advected heat - total (w/m2) + real, intent(in) :: pahg !precipitation advected heat - total (w/m2) + real, intent(in) :: pahb !precipitation advected heat - total (w/m2) + + integer :: iz !do-loop index + real :: end_wb !water storage at end of a timestep [mm] + !kwm real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + real :: fsrvg + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- +!jref:start + errsw = swdown - (fsa + fsr) +! errsw = swdown - (sav+sag + fsrv+fsrg) +! write(*,*) "errsw =",errsw + if (abs(errsw) > 0.01) then ! w/m2 + write(*,*) "vegetation!" + write(*,*) "swdown*fveg =",swdown*fveg + write(*,*) "fveg*(sav+sag) =",fveg*sav + sag + write(*,*) "fveg*(fsrv +fsrg)=",fveg*fsrv + fsrg + write(*,*) "ground!" + write(*,*) "(1-.fveg)*swdown =",(1.-fveg)*swdown + write(*,*) "(1.-fveg)*sag =",(1.-fveg)*sag + write(*,*) "(1.-fveg)*fsrg=",(1.-fveg)*fsrg + write(*,*) "fsrv =",fsrv + write(*,*) "fsrg =",fsrg + write(*,*) "fsr =",fsr + write(*,*) "sav =",sav + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa +!jref:end + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("stop in noah-mp") + end if + + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah +! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) + if(abs(erreng) > 0.01) then + write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net solar: ",fsa + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net longwave: ",fira + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total sensible: ",fsh + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "canopy evap: ",fcev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "ground evap: ",fgev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "transpiration: ",fctr + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total ground: ",ssoil + call wrf_message(trim(message)) + write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "precip: ",prcp + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "veg fraction: ",fveg + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp lsm") + end if + + if (ist == 1) then !soil + end_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + end_wb = end_wb + smc(iz) * dzsnso(iz) * 1000. + end do + errwat = end_wb-beg_wb-(prcp-ecan-etran-edir-runsrf-runsub)*dt + + else !kwm + errwat = 0.0 !kwm + endif + + end subroutine error + +!== begin energy =================================================================================== + + subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap,tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + +! -------------------------------------------------------------------------------------------------- +! we use different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. we use 'tile' approach to compute turbulent fluxes, while we use modified two- +! stream to compute radiation transfer. tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. the +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree +! crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / o o o o o o o o / / +! / | | | | | | | | / / +! / o o o o o o o o / / +! / | | |tile1| | | | / tile2 / +! / o o o o o o o o / bare / +! / | | | vegetated | | / / +! / o o o o o o o o / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (yang and friedl, 2003, jgr; niu ang yang, 2004, jgr) +! -------------------------------------- two-stream treats leaves as +! / o o o o o o o o / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / o o o o o o o o / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / o o o o o o o o / the left figure). we assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / o o o o o o o o / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. the 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc + integer , intent(in) :: jloc + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: ist !surface type: 1->soil; 2->lake + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: thair !potential temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: elai !lai adjusted for burying by snow + real , intent(in) :: esai !lai adjusted for burying by snow + real , intent(in) :: fwet !fraction of canopy that is wet [-] + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: canliq !canopy-intercepted liquid water (mm) + real , intent(in) :: canice !canopy-intercepted ice mass (mm) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + real , intent(in) :: igs !growing season index (0=off, 1=on) + + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + real, intent(in) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(in) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(in) :: pahb !precipitation advected heat - bare ground net (w/m2) + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !horisontal resolution + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: q2 !mixing ratio (kg/kg) +!jref:end + +! outputs + real , intent(out) :: z0wrf !combined z0 sent to coupled model + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: fsno !snow cover fraction (-) + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sav !solar rad. absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: taux !wind stress: e-w (n/m2) + real , intent(out) :: tauy !wind stress: n-s (n/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evaporation (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: psn !total photosyn. (umolco2/m2/s) [+] + real , intent(out) :: apar !total photosyn. active energy (w/m2) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , dimension( 1:nsoil), intent(out) :: btrani !soil water transpiration factor (0-1) + real , intent(out) :: btran !soil water transpiration factor (0-1) +! real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(out) :: frozen_ground ! used to define latent heat pathway + logical , intent(out) :: frozen_canopy ! used to define latent heat pathway + +!jref:start + real , intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real , intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) +!jref:end - out for debug + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real , intent(out) :: bgap + real , intent(out) :: wgap +!jref:end + +! input & output + real , intent(inout) :: ts !surface temperature (k) + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air temperature (k) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: q1 +! real :: q2e + real, intent(out) :: emissi + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +! local + integer :: iz !do-loop index + logical :: veg !true if vegetated surface + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: fsun !sunlit fraction of canopy [-] + real :: rb !leaf boundary layer resistance (s/m) + real :: rsurf !ground surface resistance (s/m) + real :: l_rsurf!dry-layer thickness for computing rsurf (sakaguchi and zeng, 2009) + real :: d_rsurf!reduced vapor diffusivity in soil for computing rsurf (sz09) + real :: bevap !soil water evaporation factor (0- 1) + real :: mol !monin-obukhov length (m) + real :: vai !sum of lai + stem area index [m2/m2] + real :: cwp !canopy wind extinction parameter + real :: zpd !zero plane displacement (m) + real :: z0m !z0 momentum (m) + real :: zpdg !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emv !vegetation emissivity + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + + real :: laisun !sunlit leaf area index (m2/m2) + real :: laisha !shaded leaf area index (m2/m2) + real :: psnsun !sunlit photosynthesis (umolco2/m2/s) + real :: psnsha !shaded photosynthesis (umolco2/m2/s) +!jref:start - for debug +! real :: rssun !sunlit stomatal resistance (s/m) +! real :: rssha !shaded stomatal resistance (s/m) +!jref:end - for debug + real :: parsun !par absorbed per sunlit lai (w/m2) + real :: parsha !par absorbed per shaded lai (w/m2) + + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: bdsno !bulk density of snow (kg/m3) + real :: fmelt !melting factor for snow cover frac + real :: gx !temporary variable + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) +! real :: gamma !psychrometric constant (pa/k) + real :: gammav !psychrometric constant (pa/k) + real :: gammag !psychrometric constant (pa/k) + real :: psi !surface layer soil matrix potential (m) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! temperature and fluxes over vegetated fraction + + real :: tauxv !wind stress: e-w dir [n/m2] + real :: tauyv !wind stress: n-s dir [n/m2] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] +!jref:start + real,intent(out) :: q2v + real,intent(out) :: q2b + real,intent(out) :: q2e +!jref:end + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgv !ground surface temp. [k] + real :: cmv !momentum drag coefficient + real,intent(out) :: chv !sensible heat exchange coefficient + +! temperature and fluxes over bare soil fraction + + real :: tauxb !wind stress: e-w dir [n/m2] + real :: tauyb !wind stress: n-s dir [n/m2] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgb !ground surface temp. [k] + real :: cmb !momentum drag coefficient + real,intent(out) :: chb !sensible heat exchange coefficient + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient +!jref:start + real,intent(out) :: chv2 !sensible heat conductance, canopy air to zlvl air (m/s) + real,intent(out) :: chb2 !sensible heat conductance, canopy air to zlvl air (m/s) + real :: noahmpres + +!jref:end + + real, parameter :: mpe = 1.e-6 + real, parameter :: psiwlt = -150. !metric potential for wilting point (m) + real, parameter :: z0 = 0.01 ! bare-soil roughness length (m) (i.e., under the canopy) + +! --------------------------------------------------------------------------------------------------- +! initialize fluxes from veg. fraction + + tauxv = 0. + tauyv = 0. + irc = 0. + shc = 0. + irg = 0. + shg = 0. + evg = 0. + evc = 0. + tr = 0. + ghv = 0. + psnsun = 0. + psnsha = 0. + t2mv = 0. + q2v = 0. + chv = 0. + chleaf = 0. + chuc = 0. + chv2 = 0. + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! vegetated or non-vegetated + + vai = elai + esai + veg = .false. + if(vai > 0.) veg = .true. + +! ground snow cover fraction [niu and yang, 2007, jgr] + + fsno = 0. + if(snowh.gt.0.) then + bdsno = sneqv / snowh + fmelt = (bdsno/100.)**parameters%mfsno + fsno = tanh( snowh /(2.5* z0 * fmelt)) + endif + +! ground roughness length + + if(ist == 2) then + if(tg .le. tfrz) then + z0mg = 0.01 * (1.0-fsno) + fsno * parameters%z0sno + else + z0mg = 0.01 + end if + else + z0mg = z0 * (1.0-fsno) + fsno * parameters%z0sno + end if + +! roughness length and displacement height + + zpdg = snowh + if(veg) then + z0m = parameters%z0mvt + zpd = 0.65 * parameters%hvt + if(snowh.gt.zpd) zpd = snowh + else + z0m = z0mg + zpd = zpdg + end if + + zlvl = max(zpd,parameters%hvt) + zref + if(zpdg >= zlvl) zlvl = zpdg + zref +! ur = ur*log(zlvl/z0m)/log(10./z0m) !input ur is at 10m + +! canopy wind absorption coeffcient + + cwp = parameters%cwpvt + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground and canopy + + call radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap ) !out + +! vegetation and ground emissivity + + emv = 1. - exp(-(elai+esai)/1.0) + if (ice == 1) then + emg = 0.98*(1.-fsno) + 1.0*fsno + else + emg = parameters%eg(ist)*(1.-fsno) + 1.0*fsno + end if + +! soil moisture factor controlling stomatal resistance + + btran = 0. + + if(ist ==1 ) then + do iz = 1, parameters%nroot + if(opt_btr == 1) then ! noah + gx = (sh2o(iz)-parameters%smcwlt) / (parameters%smcref-parameters%smcwlt) + end if + if(opt_btr == 2) then ! clm + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = (1.-psi/psiwlt)/(1.+parameters%psisat/psiwlt) + end if + if(opt_btr == 3) then ! ssib + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = 1.-exp(-5.8*(log(psiwlt/psi))) + end if + + gx = min(1.,max(0.,gx)) + btrani(iz) = max(mpe,dzsnso(iz) / (-zsoil(parameters%nroot)) * gx) + btran = btran + btrani(iz) + end do + btran = max(mpe,btran) + + btrani(1:parameters%nroot) = btrani(1:parameters%nroot)/btran + end if + +! soil surface resistance for ground evap. + + bevap = max(0.0,sh2o(1)/parameters%smcmax) + if(ist == 2) then + rsurf = 1. ! avoid being divided by 0 + rhsur = 1.0 + else + + ! rsurf based on sakaguchi and zeng, 2009 + ! taking the "residual water content" to be the wilting point, + ! and correcting the exponent on the d term (typo in sz09 ?) + l_rsurf = (-zsoil(1)) * ( exp ( (1.0 - min(1.0,sh2o(1)/parameters%smcmax)) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) + d_rsurf = 2.2e-5 * parameters%smcmax * parameters%smcmax * ( 1.0 - parameters%smcwlt / parameters%smcmax ) ** (2.0+3.0/parameters%bexp) + rsurf = l_rsurf / d_rsurf + + ! older rsurf computations: + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-4.225*bevap) !sellers (1992) + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-6.0 *bevap) !adjusted to decrease rsurf for wet soil + + if(sh2o(1) < 0.01 .and. snowh == 0.) rsurf = 1.e6 + psi = -parameters%psisat*(max(0.01,sh2o(1))/parameters%smcmax)**(-parameters%bexp) + rhsur = fsno + (1.-fsno) * exp(psi*grav/(rw*tg)) + end if + +! urban - jref + if (parameters%urban_flag .and. snowh == 0. ) then + rsurf = 1.e6 + endif + +! set psychrometric constant + + if (tv .gt. tfrz) then ! barlage: add distinction between ground and + latheav = hvap ! vegetation in v3.6 + frozen_canopy = .false. + else + latheav = hsub + frozen_canopy = .true. + end if + gammav = cpair*sfcprs/(0.622*latheav) + + if (tg .gt. tfrz) then + latheag = hvap + frozen_ground = .false. + else + latheag = hsub + frozen_ground = .true. + end if + gammag = cpair*sfcprs/(0.622*latheag) + +! if (sfctmp .gt. tfrz) then +! lathea = hvap +! else +! lathea = hsub +! end if +! gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and canopy and energy fluxes + + if (veg .and. fveg > 0) then + tgv = tg + cmv = cm + chv = ch +! YRQ +! write(*,*) 'cm,ch,tv,tgv, YRQ', cm,ch,tv,tgv + call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tgv ,cmv , & !inout + chv ,dx ,dz8w , & !inout + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,ghv , & !out + t2mv ,psnsun ,psnsha , & !out +!jref:start + qc ,qsfc ,psfc , & !in + q2v ,chv2, chleaf, chuc) !inout +!jref:end + end if + + tgb = tg + cmb = cm + chb = ch + call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in + emg ,stc ,df ,rsurf ,latheag , & !in + gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cmb ,chb , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,vegtyp , & !out +!jref:start + qc ,qsfc ,psfc , & !in + sfcprs ,q2b, chb2) !in +!jref:end + +!energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg +!energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg +!energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg + + if (veg .and. fveg > 0) then + taux = fveg * tauxv + (1.0 - fveg) * tauxb + tauy = fveg * tauyv + (1.0 - fveg) * tauyb + fira = fveg * irg + (1.0 - fveg) * irb + irc + fsh = fveg * shg + (1.0 - fveg) * shb + shc + fgev = fveg * evg + (1.0 - fveg) * evb + ssoil = fveg * ghv + (1.0 - fveg) * ghb + fcev = evc + fctr = tr + pah = fveg * pahg + (1.0 - fveg) * pahb + pahv + tg = fveg * tgv + (1.0 - fveg) * tgb + t2m = fveg * t2mv + (1.0 - fveg) * t2mb + ts = fveg * tv + (1.0 - fveg) * tgb + cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average? + ch = fveg * chv + (1.0 - fveg) * chb + q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc + q2e = fveg * q2v + (1.0 - fveg) * q2b + z0wrf = z0m + else + taux = tauxb + tauy = tauyb + fira = irb + fsh = shb + fgev = evb + ssoil = ghb + tg = tgb + t2m = t2mb + fcev = 0. + fctr = 0. + pah = pahb + ts = tg + cm = cmb + ch = chb + q1 = qsfc + q2e = q2b + rssun = 0.0 + rssha = 0.0 + tgv = tgb + chv = chb + z0wrf = z0mg + end if + + fire = lwdn + fira + + if(fire <=0.) then + write(6,*) 'emitted longwave <0; skin t may be wrong due to inconsistent' + write(6,*) 'input of shdfac with lai' + write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg + write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh + call wrf_error_fatal("stop in noah-mp") + end if + + ! compute a net emissivity + emissi = fveg * ( emg*(1-emv) + emv + emv*(1-emv)*(1-emg) ) + & + (1-fveg) * emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + + ! old trad calculation not taking into account emissivity: + ! trad = (fire/sb)**0.25 + + apar = parsun*laisun + parsha*laisha + psn = psnsun*laisun + psnsha*laisha + +! 3l snow & 4l soil temperatures + + call tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) then + tgv = tfrz + tgb = tfrz + if (veg .and. fveg > 0) then + tg = fveg * tgv + (1.0 - fveg) * tgb + ts = fveg * tv + (1.0 - fveg) * tgb + else + tg = tgb + ts = tgb + end if + end if + end if + +! energy released or consumed by snow & frozen soil + + call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy + +!== begin thermoprop =============================================================================== + + subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + integer , intent(in) :: ist !surface type + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension( 1:nsoil), intent(in) :: sh2o !liquid soil moisture [m3/m3] + real , intent(in) :: snowh !snow height [m] + real, intent(in) :: tg !surface temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil/lake temp. (k) + real, intent(in) :: ur !wind speed at zlvl (m/s) + real, intent(in) :: lat !latitude (radians) + real, intent(in) :: z0m !roughness length (m) + real, intent(in) :: zlvl !reference height (m) + integer , intent(in) :: vegtyp !vegtyp type + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real, dimension( 1:nsoil) :: sice !soil ice content +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties + + do iz = 1, nsoil + sice(iz) = smc(iz) - sh2o(iz) + hcpct(iz) = sh2o(iz)*cwat + (1.0-parameters%smcmax)*parameters%csoil & + + (parameters%smcmax-smc(iz))*cpair + sice(iz)*cice + call tdfcnd (parameters,df(iz), smc(iz), sh2o(iz)) + end do + + if ( parameters%urban_flag ) then + do iz = 1,nsoil + df(iz) = 3.24 + end do + endif + +! heat flux reduction effect from the overlying green canopy, adapted from +! section 2.1.2 of peters-lidard et al. (1997, jgr, vol 102(d4)). +! not in use because of the separation of the canopy layer from the ground. +! but this may represent the effects of leaf litter (niu comments) +! df1 = df1 * exp (sbeta * shdfac) + +! compute lake thermal properties +! (no consideration of turbulent mixing for this version) + + if(ist == 2) then + do iz = 1, nsoil + if(stc(iz) > tfrz) then + hcpct(iz) = cwat + df(iz) = tkwat !+ keddy * cwat + else + hcpct(iz) = cice + df(iz) = tkice + end if + end do + end if + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop + +!== begin csnow ==================================================================================== + + subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow + +!== begin tdfcnd =================================================================================== + + subroutine tdfcnd (parameters, df, smc, sh2o) +! -------------------------------------------------------------------------------------------------- +! calculate thermal diffusivity and conductivity of the soil. +! peters-lidard approach (peters-lidard et al., 1998) +! -------------------------------------------------------------------------------------------------- +! code history: +! june 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: smc ! total soil water + real, intent(in) :: sh2o ! liq. soil water + real, intent(out) :: df ! thermal diffusivity + +! local variables + real :: ake + real :: gammd + real :: thkdry + real :: thko ! thermal conductivity for other soil components + real :: thkqtz ! thermal conductivity for quartz + real :: thksat ! + real :: thks ! thermal conductivity for the solids + real :: thkw ! water thermal conductivity + real :: satratio + real :: xu + real :: xunfroz +! -------------------------------------------------------------------------------------------------- +! we now get quartz as an input argument (set in routine redprm): +! data quartz /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! -------------------------------------------------------------------------------------------------- +! if the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! -------------------------------------------------------------------------------------------------- +! quartz ....quartz content (soil type dependent) +! -------------------------------------------------------------------------------------------------- +! use as in peters-lidard, 1998 (modif. from johansen, 1975). + +! pablo grunmann, 08/17/98 +! refs.: +! farouki, o.t.,1986: thermal properties of soils. series on rock +! and soil mechanics, vol. 11, trans tech, 136 pp. +! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis, +! university of trondheim, +! peters-lidard, c. d., et al., 1998: the effect of soil thermal +! conductivity parameterization on surface energy fluxes +! and temperatures. journal of the atmospheric sciences, +! vol. 55, pp. 1209-1224. +! -------------------------------------------------------------------------------------------------- +! needs parameters +! porosity(soil type): +! poros = smcmax +! saturation ratio: +! parameters w/(m.k) + satratio = smc / parameters%smcmax + thkw = 0.57 +! if (quartz .le. 0.2) thko = 3.0 + thko = 2.0 +! solids' conductivity +! quartz' conductivity + thkqtz = 7.7 + +! unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) + thks = (thkqtz ** parameters%quartz)* (thko ** (1. - parameters%quartz)) + +! unfrozen volume for saturation (porosity*xunfroz) + xunfroz = sh2o / smc +! saturated thermal conductivity + xu = xunfroz * parameters%smcmax + +! dry density in kg/m3 + thksat = thks ** (1. - parameters%smcmax)* tkice ** (parameters%smcmax - xu)* thkw ** & + (xu) + +! dry thermal conductivity in w.m-1.k-1 + gammd = (1. - parameters%smcmax)*2700. + + thkdry = (0.135* gammd+ 64.7)/ (2700. - 0.947* gammd) +! frozen + if ( (sh2o + 0.0005) < smc ) then + ake = satratio +! unfrozen +! range of validity for the kersten number (ake) + else + +! kersten number (using "fine" formula, valid for soils containing at +! least 5% of particles with diameter less than 2.e-6 meters.) +! (for "coarse" formula, see peters-lidard et al., 1998). + + if ( satratio > 0.1 ) then + + ake = log10 (satratio) + 1.0 + +! use k = kdry + else + + ake = 0.0 + end if +! thermal conductivity + + end if + + df = ake * (thksat - thkdry) + thkdry + + + end subroutine tdfcnd + +!== begin radiation ================================================================================ + + subroutine radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + integer, intent(in) :: nsoil !number of soil layers + + real, intent(in) :: dt !time step [s] + real, intent(in) :: qsnow !snowfall (mm/s) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water [m3/m3] + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, intent(in) :: fsno !snow cover fraction (-) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age. + +! output + real, intent(out) :: fsun !sunlit fraction of canopy (-) + real, intent(out) :: laisun !sunlit leaf area (-) + real, intent(out) :: laisha !shaded leaf area (-) + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + +!jref:start + real, intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real, intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! local + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albgrd !ground albedo (direct) + real, dimension(1:2) :: albgri !ground albedo (diffuse) + real, dimension(1:2) :: albd !surface albedo (direct) + real, dimension(1:2) :: albi !surface albedo (diffuse) + real, dimension(1:2) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1:2) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1:2) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1:2) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1:2) :: ftii !down diffuse flux below veg (per unit dif flux) +!jref:start + real, dimension(1:2) :: frevi + real, dimension(1:2) :: frevd + real, dimension(1:2) :: fregi + real, dimension(1:2) :: fregd +!jref:end + + real :: fsha !shaded fraction of canopy + real :: vai !total lai + stem area index, one sided + + real,parameter :: mpe = 1.e-6 + logical veg !true: vegetated for surface temperature calculation + +! -------------------------------------------------------------------------------------------------- + +! surface abeldo + + call albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !) !out + frevi ,frevd ,fregd ,fregi ,bgap , & !inout + wgap) + +! surface radiation + + fsha = 1.-fsun + laisun = elai*fsun + laisha = elai*fsha + vai = elai+ esai + if (vai .gt. 0.) then + veg = .true. + else + veg = .false. + end if + + call surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !out + frevi ,frevd ,fregd ,fregi ,fsrv , & !inout + fsrg) + + end subroutine radiation + +!== begin albedo =================================================================================== + + subroutine albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !out + frevi ,frevd ,fregd ,fregi ,bgap , & !out + wgap) + +! -------------------------------------------------------------------------------------------------- +! surface albedos. also fluxes (per unit incoming direct and diffuse +! radiation) reflected, transmitted, and absorbed by vegetation. +! also sunlit fraction of the canopy. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + + real, intent(in) :: dt !time step [sec] + real, intent(in) :: qsnow !snowfall + real, intent(in) :: cosz !cosine solar zenith angle for next time step + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fsno !fraction of grid covered by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water (m3/m3) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse) + real, dimension(1: 2), intent(out) :: albd !surface albedo (direct) + real, dimension(1: 2), intent(out) :: albi !surface albedo (diffuse) + real, dimension(1: 2), intent(out) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1: 2), intent(out) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1: 2), intent(out) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftii !down diffuse flux below veg (per unit dif flux) + real, intent(out) :: fsun !sunlit fraction of canopy (-) +!jref:start + real, dimension(1: 2), intent(out) :: frevd + real, dimension(1: 2), intent(out) :: frevi + real, dimension(1: 2), intent(out) :: fregd + real, dimension(1: 2), intent(out) :: fregi + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! ------------------------------------------------------------------------ +! ------------------------ local variables ------------------------------- +! local + real :: fage !snow age function + real :: alb + integer :: ib !indices + integer :: nband !number of solar radiation wave bands + integer :: ic !direct beam: ic=0; diffuse: ic=1 + + real :: wl !fraction of lai+sai that is lai + real :: ws !fraction of lai+sai that is sai + real :: mpe !prevents overflow for division by zero + + real, dimension(1:2) :: rho !leaf/stem reflectance weighted by fraction lai and sai + real, dimension(1:2) :: tau !leaf/stem transmittance weighted by fraction lai and sai + real, dimension(1:2) :: ftdi !down direct flux below veg per unit dif flux = 0 + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + + real :: vai !elai+esai + real :: gdir !average projected leaf/stem area in solar direction + real :: ext !optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + mpe = 1.e-06 + bgap = 0. + wgap = 0. + +! initialize output because solar radiation only done if cosz > 0 + + do ib = 1, nband + albd(ib) = 0. + albi(ib) = 0. + albgrd(ib) = 0. + albgri(ib) = 0. + fabd(ib) = 0. + fabi(ib) = 0. + ftdd(ib) = 0. + ftid(ib) = 0. + ftii(ib) = 0. + if (ib.eq.1) fsun = 0. + end do + + if(cosz <= 0) goto 100 + +! weight reflectance/transmittance by lai and sai + + do ib = 1, nband + vai = elai + esai + wl = elai / max(vai,mpe) + ws = esai / max(vai,mpe) + rho(ib) = max(parameters%rhol(ib)*wl+parameters%rhos(ib)*ws, mpe) + tau(ib) = max(parameters%taul(ib)*wl+parameters%taus(ib)*ws, mpe) + end do + +! snow age + + call snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: only if cosz > 0 and fsno > 0 + + if(opt_alb == 1) & + call snowalb_bats (parameters,nband, fsno,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) + albold = alb + end if + +! ground surface albedo + + call groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out + +! loop over nband wavebands to calculate surface albedos and solar +! fluxes for unit incoming direct (ic=0) and diffuse flux (ic=1) + + do ib = 1, nband + ic = 0 ! direct + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabd ,albd ,ftdd ,ftid ,gdir , &!) !out + frevd ,fregd ,bgap ,wgap) + + ic = 1 ! diffuse + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabi ,albi ,ftdi ,ftii ,gdir , & !) !out + frevi ,fregi ,bgap ,wgap) + + end do + +! sunlit fraction of canopy. set fsun = 0 if fsun < 0.01. + + ext = gdir/cosz * sqrt(1.-rho(1)-tau(1)) + fsun = (1.-exp(-ext*vai)) / max(ext*vai,mpe) + ext = fsun + + if (ext .lt. 0.01) then + wl = 0. + else + wl = ext + end if + fsun = wl + +100 continue + + end subroutine albedo + +!== begin surrad =================================================================================== + + subroutine surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !) !out + frevi ,frevd ,fregd ,fregi ,fsrv , & + fsrg) !inout + +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + real, intent(in) :: mpe !prevents underflow errors if division by zero + + real, intent(in) :: fsun !sunlit fraction of canopy + real, intent(in) :: fsha !shaded fraction of canopy + real, intent(in) :: elai !leaf area, one-sided + real, intent(in) :: vai !leaf + stem area, one-sided + real, intent(in) :: laisun !sunlit leaf area index, one-sided + real, intent(in) :: laisha !shaded leaf area index, one-sided + + real, dimension(1:2), intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2), intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, dimension(1:2), intent(in) :: fabd !flux abs by veg (per unit incoming direct flux) + real, dimension(1:2), intent(in) :: fabi !flux abs by veg (per unit incoming diffuse flux) + real, dimension(1:2), intent(in) :: ftdd !down dir flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftid !down dif flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftii !down dif flux below veg (per incoming dif flux) + real, dimension(1:2), intent(in) :: albgrd !ground albedo (direct) + real, dimension(1:2), intent(in) :: albgri !ground albedo (diffuse) + real, dimension(1:2), intent(in) :: albd !overall surface albedo (direct) + real, dimension(1:2), intent(in) :: albi !overall surface albedo (diffuse) + + real, dimension(1:2), intent(in) :: frevd !overall surface albedo veg (direct) + real, dimension(1:2), intent(in) :: frevi !overall surface albedo veg (diffuse) + real, dimension(1:2), intent(in) :: fregd !overall surface albedo grd (direct) + real, dimension(1:2), intent(in) :: fregi !overall surface albedo grd (diffuse) + +! output + + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsrv !reflected solar radiation by vegetation + real, intent(out) :: fsrg !reflected solar radiation by ground + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband number (1=vis, 2=nir) + integer :: nband !number of solar radiation waveband classes + + real :: abs !absorbed solar radiation (w/m2) + real :: rnir !reflected solar radiation [nir] (w/m2) + real :: rvis !reflected solar radiation [vis] (w/m2) + real :: laifra !leaf area fraction of canopy + real :: trd !transmitted solar radiation: direct (w/m2) + real :: tri !transmitted solar radiation: diffuse (w/m2) + real, dimension(1:2) :: cad !direct beam absorbed by canopy (w/m2) + real, dimension(1:2) :: cai !diffuse radiation absorbed by canopy (w/m2) +! --------------------------------------------------------------------------------------------- + nband = 2 + +! zero summed solar fluxes + + sag = 0. + sav = 0. + fsa = 0. + +! loop over nband wavebands + + do ib = 1, nband + +! absorbed by canopy + + cad(ib) = solad(ib)*fabd(ib) + cai(ib) = solai(ib)*fabi(ib) + sav = sav + cad(ib) + cai(ib) + fsa = fsa + cad(ib) + cai(ib) + +! transmitted solar fluxes incident on ground + + trd = solad(ib)*ftdd(ib) + tri = solad(ib)*ftid(ib) + solai(ib)*ftii(ib) + +! solar radiation absorbed by ground surface + + abs = trd*(1.-albgrd(ib)) + tri*(1.-albgri(ib)) + sag = sag + abs + fsa = fsa + abs + end do + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + + laifra = elai / max(vai,mpe) + if (fsun .gt. 0.) then + parsun = (cad(1)+fsun*cai(1)) * laifra / max(laisun,mpe) + parsha = (fsha*cai(1))*laifra / max(laisha,mpe) + else + parsun = 0. + parsha = (cad(1)+cai(1))*laifra /max(laisha,mpe) + endif + +! reflected solar radiation + + rvis = albd(1)*solad(1) + albi(1)*solai(1) + rnir = albd(2)*solad(2) + albi(2)*solai(2) + fsr = rvis + rnir + +! reflected solar radiation of veg. and ground (combined ground) + fsrv = frevd(1)*solad(1)+frevi(1)*solai(1)+frevd(2)*solad(2)+frevi(2)*solai(2) + fsrg = fregd(1)*solad(1)+fregi(1)*solai(1)+fregd(2)*solad(2)+fregi(2)*solai(2) + + + end subroutine surrad + +!== begin snow_age ================================================================================= + + subroutine snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) +! ---------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +!output + real, intent(out) :: fage !snow age + +!input/output + real, intent(inout) :: tauss !non-dimensional snow age +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / parameters%swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age + +!== begin snowalb_bats ============================================================================= + + subroutine snowalb_bats (parameters,nband,fsno,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fsno !snow cover fraction (-) + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats + +!== begin snowalb_class ============================================================================ + + subroutine snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow,parameters%swemx/dt) * (0.84-alb)/(parameters%swemx/dt) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class + +!== begin groundalb ================================================================================ + + subroutine groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: nband !number of solar radiation waveband classes + integer, intent(in) :: ice !value of ist for land ice + integer, intent(in) :: ist !surface type + real, intent(in) :: fsno !fraction of surface covered with snow (-) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water content (m3/m3) + real, dimension(1: 2), intent(in) :: albsnd !direct beam snow albedo (vis, nir) + real, dimension(1: 2), intent(in) :: albsni !diffuse snow albedo (vis, nir) + +!output + + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct beam: vis, nir) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse: vis, nir) + +!local + + integer :: ib !waveband number (1=vis, 2=nir) + real :: inc !soil water correction factor for soil albedo + real :: albsod !soil albedo (direct) + real :: albsoi !soil albedo (diffuse) +! -------------------------------------------------------------------------------------------------- + + do ib = 1, nband + inc = max(0.11-0.40*smc(1), 0.) + if (ist .eq. 1) then !soil + albsod = min(parameters%albsat(ib)+inc,parameters%albdry(ib)) + albsoi = albsod + else if (tg .gt. tfrz) then !unfrozen lake, wetland + albsod = 0.06/(max(0.01,cosz)**1.7 + 0.15) + albsoi = 0.06 + else !frozen lake, wetland + albsod = parameters%alblak(ib) + albsoi = albsod + end if + +! increase desert and semi-desert albedos + +! if (ist .eq. 1 .and. isc .eq. 9) then +! albsod = albsod + 0.10 +! albsoi = albsoi + 0.10 +! end if + + albgrd(ib) = albsod*(1.-fsno) + albsnd(ib)*fsno + albgri(ib) = albsoi*(1.-fsno) + albsni(ib)*fsno + end do + + end subroutine groundalb + +!== begin twostream ================================================================================ + + subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,t ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fab ,fre ,ftd ,fti ,gdir , & !) !out + frev ,freg ,bgap ,wgap) + +! -------------------------------------------------------------------------------------------------- +! use two-stream approximation of dickinson (1983) adv geophysics +! 25:305-353 and sellers (1985) int j remote sensing 6:1335-1372 +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or diffuse +! flux given an underlying surface with known albedo. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: ist !surface type + integer, intent(in) :: ib !waveband number + integer, intent(in) :: ic !0=unit incoming direct; 1=unit incoming diffuse + integer, intent(in) :: vegtyp !vegetation type + + real, intent(in) :: cosz !cosine of direct zenith angle (0-1) + real, intent(in) :: vai !one-sided leaf+stem area index (m2/m2) + real, intent(in) :: fwet !fraction of lai, sai that is wetted (-) + real, intent(in) :: t !surface temperature (k) + + real, dimension(1:2), intent(in) :: albgrd !direct albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: albgri !diffuse albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: rho !leaf+stem reflectance + real, dimension(1:2), intent(in) :: tau !leaf+stem transmittance + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! output + + real, dimension(1:2), intent(out) :: fab !flux abs by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: fre !flux refl above veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: ftd !down dir flux below veg layer (per unit in flux) + real, dimension(1:2), intent(out) :: fti !down dif flux below veg layer (per unit in flux) + real, intent(out) :: gdir !projected leaf+stem area in solar direction + real, dimension(1:2), intent(out) :: frev !flux reflected by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: freg !flux reflected by ground (per unit incoming flux) + +! local + real :: omega !fraction of intercepted radiation that is scattered + real :: omegal !omega for leaves + real :: betai !upscatter parameter for diffuse radiation + real :: betail !betai for leaves + real :: betad !upscatter parameter for direct beam radiation + real :: betadl !betad for leaves + real :: ext !optical depth of direct beam per unit leaf area + real :: avmu !average diffuse optical depth + + real :: coszi !0.001 <= cosz <= 1.000 + real :: asu !single scattering albedo + real :: chil ! -0.4 <= xl <= 0.6 + + real :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9 + real :: p1,p2,p3,p4,s1,s2,u1,u2,u3 + real :: b,c,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10 + real :: phi1,phi2,sigma + real :: ftds,ftis,fres + real :: denfveg + real :: vai_spread +!jref:start + real :: freveg,frebar,ftdveg,ftiveg,ftdbar,ftibar + real :: thetaz +!jref:end + +! variables for the modified two-stream scheme +! niu and yang (2004), jgr + + real, parameter :: pai = 3.14159265 + real :: hd !crown depth (m) + real :: bb !vertical crown radius (m) + real :: thetap !angle conversion from sza + real :: fa !foliage volume density (m-1) + real :: newvai !effective lsai (-) + + real,intent(inout) :: bgap !between canopy gap fraction for beam (-) + real,intent(inout) :: wgap !within canopy gap fraction for beam (-) + + real :: kopen !gap fraction for diffue light (-) + real :: gap !total gap fraction for beam ( <=1-shafac ) + +! ----------------------------------------------------------------- +! compute within and between gaps + vai_spread = vai + if(vai == 0.0) then + gap = 1.0 + kopen = 1.0 + else + if(opt_rad == 1) then + denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2) + hd = parameters%hvt - parameters%hvb + bb = 0.5 * hd + thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) ) + ! bgap = exp(-parameters%den * pai * parameters%rc**2/cos(thetap) ) + bgap = exp(-denfveg * pai * parameters%rc**2/cos(thetap) ) + fa = vai/(1.33 * pai * parameters%rc**3.0 *(bb/parameters%rc)*denfveg) + newvai = hd*fa + wgap = (1.0-bgap) * exp(-0.5*newvai/cosz) + gap = min(1.0-fveg, bgap+wgap) + + kopen = 0.05 + end if + + if(opt_rad == 2) then + gap = 0.0 + kopen = 0.0 + end if + + if(opt_rad == 3) then + gap = 1.0-fveg + kopen = 1.0-fveg + end if + end if + +! calculate two-stream parameters omega, betad, betai, avmu, gdir, ext. +! omega, betad, betai are adjusted for snow. values for omega*betad +! and omega*betai are calculated and then divided by the new omega +! because the product omega*betai, omega*betad is used in solution. +! also, the transmittances and reflectances (tau, rho) are linear +! weights of leaf and stem values. + + coszi = max(0.001, cosz) + chil = min( max(parameters%xl, -0.4), 0.6) + if (abs(chil) .le. 0.01) chil = 0.01 + phi1 = 0.5 - 0.633*chil - 0.330*chil*chil + phi2 = 0.877 * (1.-2.*phi1) + gdir = phi1 + phi2*coszi + ext = gdir/coszi + avmu = ( 1. - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2 + omegal = rho(ib) + tau(ib) + tmp0 = gdir + phi2*coszi + tmp1 = phi1*coszi + asu = 0.5*omegal*gdir/tmp0 * ( 1.-tmp1/tmp0*log((tmp1+tmp0)/tmp1) ) + betadl = (1.+avmu*ext)/(omegal*avmu*ext)*asu + betail = 0.5 * ( rho(ib)+tau(ib) + (rho(ib)-tau(ib)) & + * ((1.+chil)/2.)**2 ) / omegal + +! adjust omega, betad, and betai for intercepted snow + + if (t .gt. tfrz) then !no snow + tmp0 = omegal + tmp1 = betadl + tmp2 = betail + else + tmp0 = (1.-fwet)*omegal + fwet*parameters%omegas(ib) + tmp1 = ( (1.-fwet)*omegal*betadl + fwet*parameters%omegas(ib)*parameters%betads ) / tmp0 + tmp2 = ( (1.-fwet)*omegal*betail + fwet*parameters%omegas(ib)*parameters%betais ) / tmp0 + end if + + omega = tmp0 + betad = tmp1 + betai = tmp2 + +! absorbed, reflected, transmitted fluxes per unit incoming radiation + + b = 1. - omega + omega*betai + c = omega*betai + tmp0 = avmu*ext + d = tmp0 * omega*betad + f = tmp0 * omega*(1.-betad) + tmp1 = b*b - c*c + h = sqrt(tmp1) / avmu + sigma = tmp0*tmp0 - tmp1 + if ( abs (sigma) < 1.e-6 ) sigma = sign(1.e-6,sigma) + p1 = b + avmu*h + p2 = b - avmu*h + p3 = b + tmp0 + p4 = b - tmp0 + s1 = exp(-h*vai) + s2 = exp(-ext*vai) + if (ic .eq. 0) then + u1 = b - c/albgrd(ib) + u2 = b - c*albgrd(ib) + u3 = f + c*albgrd(ib) + else + u1 = b - c/albgri(ib) + u2 = b - c*albgri(ib) + u3 = f + c*albgri(ib) + end if + tmp2 = u1 - avmu*h + tmp3 = u1 + avmu*h + d1 = p1*tmp2/s1 - p2*tmp3*s1 + tmp4 = u2 + avmu*h + tmp5 = u2 - avmu*h + d2 = tmp4/s1 - tmp5*s1 + h1 = -d*p4 - c*f + tmp6 = d - h1*p3/sigma + tmp7 = ( d - c - h1/sigma*(u1+tmp0) ) * s2 + h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1 + h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1 + h4 = -f*p3 - c*d + tmp8 = h4/sigma + tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2 + h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2 + h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2 + h7 = (c*tmp2) / (d1*s1) + h8 = (-c*tmp3*s1) / d1 + h9 = tmp4 / (d2*s1) + h10 = (-tmp5*s1) / d2 + +! downward direct and diffuse fluxes below vegetation +! niu and yang (2004), jgr. + + if (ic .eq. 0) then + ftds = s2 *(1.0-gap) + gap + ftis = (h4*s2/sigma + h5*s1 + h6/s1)*(1.0-gap) + else + ftds = 0. + ftis = (h9*s1 + h10/s1)*(1.0-kopen) + kopen + end if + ftd(ib) = ftds + fti(ib) = ftis + +! flux reflected by the surface (veg. and ground) + + if (ic .eq. 0) then + fres = (h1/sigma + h2 + h3)*(1.0-gap ) + albgrd(ib)*gap + freveg = (h1/sigma + h2 + h3)*(1.0-gap ) + frebar = albgrd(ib)*gap !jref - separate veg. and ground reflection + else + fres = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + freveg = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + frebar = 0 !jref - separate veg. and ground reflection + end if + fre(ib) = fres + + frev(ib) = freveg + freg(ib) = frebar + +! flux absorbed by vegetation + + fab(ib) = 1. - fre(ib) - (1.-albgrd(ib))*ftd(ib) & + - (1.-albgri(ib))*fti(ib) + +!if(iloc == 1.and.jloc == 2) then +! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," gap: ",gap," ftd: ",ftd(ib)," fti: ",fti(ib)," fre: ", & +! fre(ib)," fab: ",fab(ib)," albgrd: ",albgrd(ib)," albgri: ",albgri(ib) +!end if + + end subroutine twostream + +!== begin vege_flux ================================================================================ + + subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tg ,cm , & !inout + ch ,dx ,dz8w , & ! + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,gh , & !out + t2mv ,psnsun ,psnsha , & !out + qc ,qsfc ,psfc , & !in + q2v ,cah2 ,chleaf ,chuc ) !inout + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve for vegetation (tv) and +! ground (tg) temperatures that balance the surface energy budgets + +! vegetated: +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + logical, intent(in) :: veg !true if vegetated surface + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: sav !solar rad absorbed by veg (w/m2) + real, intent(in) :: sag !solar rad absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temp at reference height (k) + real, intent(in) :: eair !vapor pressure air at zlvl (pa) + real, intent(in) :: qair !specific humidity at zlvl (kg/kg) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: dt !time step (s) + real, intent(in) :: fsno !snow fraction + + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: fwet !wetted fraction of canopy + real, intent(in) :: cwp !canopy wind parameter + + real, intent(in) :: vai !total leaf area index + stem area index + real, intent(in) :: laisun !sunlit leaf area index, one-sided (m2/m2) + real, intent(in) :: laisha !shaded leaf area index, one-sided (m2/m2) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: emv !vegetation emissivity + real, intent(in) :: emg !ground emissivity + + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thinkness of snow/soil layers (m) + real, intent(in) :: canliq !intercepted liquid water (mm) + real, intent(in) :: canice !intercepted ice mass (mm) + real, intent(in) :: rsurf !ground surface resistance (s/m) +! real, intent(in) :: gamma !psychrometric constant (pa/k) +! real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammav !psychrometric constant (pa/k) + real, intent(in) :: latheav !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammag !psychrometric constant (pa/k) + real, intent(in) :: latheag !latent heat of vaporization/subli (j/kg) + real, intent(in) :: parsun !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: parsha !par absorbed per unit shaded lai (w/m2) + real, intent(in) :: foln !foliage nitrogen (%) + real, intent(in) :: co2air !atmospheric co2 concentration (pa) + real, intent(in) :: o2air !atmospheric o2 concentration (pa) + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: sfcprs !pressure (pa) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + + real , intent(in) :: qc !cloud water mixing ratio + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real, intent(in) :: pahv !precipitation advected heat - canopy net in (w/m2) + real, intent(in) :: pahg !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: eah !canopy air vapor pressure (pa) + real, intent(inout) :: tah !canopy air temperature (k) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: tg !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 + real, intent(out) :: tauxv !wind stress: e-w (n/m2) + real, intent(out) :: tauyv !wind stress: n-s (n/m2) + real, intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shc !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evc !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: irg !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shg !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evg !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: tr !transpiration heat flux (w/m2)[+= to atm] + real, intent(out) :: gh !ground heat (w/m2) [+ = to soil] + real, intent(out) :: t2mv !2 m height air temperature (k) + real, intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: chleaf !leaf exchange coefficient + real, intent(out) :: chuc !under canopy exchange coefficient + + real, intent(out) :: q2v + real :: cah !sensible heat conductance, canopy air to zlvl air (m/s) + real :: u10v !10 m wind speed in eastward dir (m/s) + real :: v10v !10 m wind speed in eastward dir (m/s) + real :: wspd + +! ------------------------ local variables ---------------------------------------------------- + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat (m) + real :: z0hg !roughness length, sensible heat (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramc !aerodynamic resistance for momentum (s/m) + real :: rahc !aerodynamic resistance for sensible heat (s/m) + real :: rawc !aerodynamic resistance for water vapor (s/m) + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + + real :: mol !monin-obukhov length (m) + real :: dtv !change in tv, last iteration (k) + real :: dtg !change in tg, last iteration (k) + + real :: air,cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + real :: atr,ctr !coefficients for tr as function of esat[ts] + real :: ata,bta !coefficients for tah as function of ts + real :: aea,bea !coefficients for eah as function of esat[ts] + + real :: estv !saturation vapor pressure at tv (pa) + real :: estg !saturation vapor pressure at tg (pa) + real :: destv !d(es)/dt at ts (pa/k) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: fhg !sen heat stability correction, ground + real :: hcan !canopy height (m) [note: hcan >= z0mg] + + real :: a !temporary calculation + real :: b !temporary calculation + real :: cvh !sensible heat conductance, leaf surface to canopy air (m/s) + real :: caw !latent heat conductance, canopy air zlvl air (m/s) + real :: ctw !transpiration conductance, leaf to canopy air (m/s) + real :: cew !evaporation conductance, leaf to canopy air (m/s) + real :: cgw !latent heat conductance, ground to canopy air (m/s) + real :: cond !sum of conductances (s/m) + real :: uc !wind speed at top of canopy (m/s) + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: h !temporary sensible heat flux (w/m2) + real :: hg !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter + real :: mozg !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: thstar !surface exchange at 2m + + real :: thvair + real :: thah + real :: rahc2 !aerodynamic resistance for sensible heat (s/m) + real :: rawc2 !aerodynamic resistance for water vapor (s/m) + real, intent(out):: cah2 !sensible heat conductance for diagnostics + real :: ch2v !exchange coefficient for 2m over vegetation. + real :: cq2v !exchange coefficient for 2m over vegetation. + real :: eah2 !2m vapor pressure over canopy + real :: qfx !moisture flux + real :: e1 + + + real :: vaie !total leaf area index + stem area index,effective + real :: laisune !sunlit leaf area index, one-sided (m2/m2),effective + real :: laishae !shaded leaf area index, one-sided (m2/m2),effective + + integer :: k !index + integer :: iter !iteration index + +!jref - niterc test from 5 to 20 + integer, parameter :: niterc = 20 !number of iterations for surface temperature +!jref - niterg test from 3-5 + integer, parameter :: niterg = 5 !number of iterations for ground temperature + integer :: mozsgn !number of times moz changes sign + real :: mpe !prevents overflow error if division by zero + + integer :: liter !last iteration + + + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + + character(len=80) :: message + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) +! --------------------------------------------------------------------------------------------- + + mpe = 1e-6 + liter = 0 + fv = 0.1 + +! --------------------------------------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! --------------------------------------------------------------------------------------------- + dtv = 0. + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + hg = 0. + h = 0. + qfx = 0. + +! YRQ +! write(*,*) 'tv,tg,stc in input:YRQ', tv,tg,stc + +! convert grid-cell lai to the fractional vegetated area (fveg) + + vaie = min(6.,vai / fveg) + laisune = min(6.,laisun / fveg) + laishae = min(6.,laisha / fveg) + +! saturation vapor pressure at ground temperature + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + +!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 + + qsfc = 0.622*eair/(psfc-0.378*eair) + +! canopy height + + hcan = parameters%hvt + uc = ur*log(hcan/z0m)/log(zlvl/z0m) + uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 + if((hcan-zpd) <= 0.) then + write(message,*) "critical problem: hcan <= zpd" + call wrf_message ( message ) + write(message,*) 'i,j point=',iloc, jloc + call wrf_message ( message ) + write(message,*) 'hcan =',hcan + call wrf_message ( message ) + write(message,*) 'zpd =',zpd + call wrf_message ( message ) + write (message, *) 'snowh =',snowh + call wrf_message ( message ) + call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" ) + end if + +! prepare for longwave rad. + + air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 + cir = (2.-emv*(1.-emg))*emv*sb +! --------------------------------------------------------------------------------------------- + loop1: do iter = 1, niterc ! begin stability iteration + + if(iter == 1) then + z0h = z0m + z0hg = z0mg + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) + end if + +! aerodyn resistances between heights zlvl and d+z0v + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tah ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + endif + + ramc = max(1.,1./(cm*ur)) + rahc = max(1.,1./(ch*ur)) + rawc = rahc + +! aerodyn resistance between heights z0g and d+z0v, rag, and leaf +! boundary layer resistance, rb + + call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out + +! es and d(es)/dt evaluated at tv + + t = tdc(tv) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estv = esatw + destv = dsatw + else + estv = esati + destv = dsati + end if + +! stomatal resistance + + if(iter == 1) then + if (opt_crs == 1) then ! ball-berry + call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssun ,psnsun) !out + + call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssha ,psnsha) !out + end if + + if (opt_crs == 2) then ! jarvis + call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in + rssun ,psnsun,iloc ,jloc ) !out + + call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in + rssha ,psnsha,iloc ,jloc ) !out + end if + end if + +! prepare for sensible heat flux above veg. + + cah = 1./rahc + cvh = 2.*vaie/rb + cgh = 1./rahg + cond = cah + cvh + cgh + ata = (sfctmp*cah + tg*cgh) / cond + bta = cvh/cond + csh = (1.-bta)*rhoair*cpair*cvh + +! prepare for latent heat flux above veg. + + caw = 1./rawc + cew = fwet*vaie/rb + ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) + cgw = 1./(rawg+rsurf) + cond = caw + cew + ctw + cgw + aea = (eair*caw + estg*cgw) / cond + bea = (cew+ctw)/cond + cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 + ctr = (1.-bea)*ctw*rhoair*cpair/gammav + +! evaluate surface fluxes with current temperature and solve for dts + + tah = ata + bta*tv ! canopy air t. + eah = aea + bea*estv ! canopy air e + + irc = fveg*(air + cir*tv**4) + shc = fveg*rhoair*cpair*cvh * ( tv-tah) + evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 + tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav + if (tv > tfrz) then + evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 + else + evc = min(canice*latheav/dt,evc) + end if + + b = sav-irc-shc-evc-tr+pahv !additional w/m2 + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + dtv = b/a + + irc = irc + fveg*4.*cir*tv**3*dtv + shc = shc + fveg*csh*dtv + evc = evc + fveg*cev*destv*dtv + tr = tr + fveg*ctr*destv*dtv + +! update vegetation surface temperature + tv = tv + dtv +! tah = ata + bta*tv ! canopy air t; update here for consistency + +! for computing m-o length in the next iteration + h = rhoair*cpair*(tah - sfctmp) /rahc + hg = rhoair*cpair*(tg - tah) /rahg + +! consistent specific humidity from canopy air vapor pressure + qsfc = (0.622*eah)/(sfcprs-0.378*eah) + + if (liter == 1) then + exit loop1 + endif + if (iter >= 5 .and. abs(dtv) <= 0.01 .and. liter == 0) then + liter = 1 + endif + + end do loop1 ! end stability iteration + +! under-canopy fluxes and tg + + air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + cir = emg*sb + csh = rhoair*cpair/rahg + cev = rhoair*cpair / (gammag*(rawg+rsurf)) ! barlage: change to ground v3.6 + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) +! write(*,*)'inside tg=',tg,'stc(1)=',stc(1) + + loop2: do iter = 1, niterg + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + irg = cir*tg**4 + air + shg = csh * (tg - tah ) + evg = cev * (estg*rhsur - eah ) + gh = cgh * (tg - stc(isnow+1)) + + b = sag-irg-shg-evg-gh+pahg + a = 4.*cir*tg**3+csh+cev*destg+cgh + dtg = b/a + + irg = irg + 4.*cir*tg**3*dtg + shg = shg + csh*dtg + evg = evg + cev*destg*dtg + gh = gh + cgh*dtg + tg = tg + dtg + + end do loop2 + +! tah = (cah*sfctmp + cvh*tv + cgh*tg)/(cah + cvh + cgh) + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tg > tfrz) then + tg = tfrz + if(opt_stc == 3) tg = (1.-fsno)*tg + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irg = cir*tg**4 - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + shg = csh * (tg - tah) + evg = cev * (estg*rhsur - eah) + gh = sag+pahg - (irg+shg+evg) + end if + end if + +! wind stresses + + tauxv = -rhoair*cm*ur*uu + tauyv = -rhoair*cm*ur*vv + +! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah +! calculation. +! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah) +! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg +! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag ) +! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag + +! 2m temperature over vegetation ( corrected for low cq2v values ) + if (opt_sfc == 1 .or. opt_sfc == 2) then +! cah2 = fv*1./vkc*log((2.+z0h)/z0h) + cah2 = fv*vkc/log((2.+z0h)/z0h) + cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2v = cah2 + if (cah2 .lt. 1.e-5 ) then + t2mv = tah +! q2v = (eah*0.622/(sfcprs - 0.378*eah)) + q2v = qsfc + else + t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2 +! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) + q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v + endif + endif + +! update ch for output + ch = cah + chleaf = cvh + chuc = 1./rahg + + end subroutine vege_flux + +!== begin bare_flux ================================================================================ + + subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in + emg ,stc ,df ,rsurf ,lathea , & !in + gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cm ,ch , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out + qc ,qsfc ,psfc , & !in + sfcprs ,q2b ,ehb2 ) !in + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for bare soil fraction. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + real, intent(in) :: dt !time step (s) + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temperature at height zlvl (k) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: snowh !actual snow depth [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: emg !ground emissivity + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: fsno !snow fraction + +!jref:start; in + integer , intent(in) :: ivgtyp + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: sfcprs !pressure at lowest model layer + real , intent(in) :: dx !horisontal grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer +!jref:end + real, intent(in) :: pahb !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + + real, intent(out) :: tauxb !wind stress: e-w (n/m2) + real, intent(out) :: tauyb !wind stress: n-s (n/m2) + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) +!jref:start + real, intent(out) :: q2b !bare ground heat conductance + real :: ehb !bare ground heat conductance + real :: u10b !10 m wind speed in eastward dir (m/s) + real :: v10b !10 m wind speed in eastward dir (m/s) + real :: wspd +!jref:end + +! local variables + + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: fira !total net longwave rad (w/m2) [+ to atm] + real :: fsh !total sensible heat flux (w/m2) [+ to atm] + real :: fgev !ground evaporation heat flux (w/m2)[+ to atm] + real :: ssoil !soil heat flux (w/m2) [+ to soil] + real :: fire !emitted ir (w/m2) + real :: trad !radiative temperature (k) + real :: tah !"surface" temperature at height z0h+zpd (k) + + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat, ground (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: mol !monin-obukhov length (m) + real :: dtg !change in tg, last iteration (k) + + real :: cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + +!jref:start + real :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) + real :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) + real,intent(out) :: ehb2 !sensible heat conductance for diagnostics + real :: ch2b !exchange coefficient for 2m temp. + real :: cq2b !exchange coefficient for 2m temp. + real :: thvair !virtual potential air temp + real :: thgh !potential ground temp + real :: emb !momentum conductance + real :: qfx !moisture flux + real :: estg2 !saturation vapor pressure at 2m (pa) + integer :: vegtyp !vegetation type set to isbarren + real :: e1 +!jref:end + + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: a !temporary calculation + real :: b !temporary calculation + real :: h !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + integer :: mozsgn !number of times moz changes sign + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + + integer :: iter !iteration index + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero +!jref:start +! data niterb /3/ + data niterb /5/ + save niterb + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + mpe = 1e-6 + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + h = 0. + qfx = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + if(iter == 1) then + z0h = z0m + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + end if + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tgb ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + if(snowh > 0.) then + cm = min(0.01,cm) ! cm & ch are too large, causing + ch = min(0.01,ch) ! computational instability + end if + + endif + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +!jref - variables for diagnostics + emb = 1./ramb + ehb = 1./rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb+pahb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) + + qfx = (qsfc-qair)*cev*gamma/cpair + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tgb > tfrz) then + tgb = tfrz + if(opt_stc == 3) tgb = (1.-fsno)*tgb + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag+pahb - (irb+shb+evb) + end if + end if + +! wind stresses + + tauxb = -rhoair*cm*ur*uu + tauyb = -rhoair*cm*ur*vv + +!jref:start; errors in original equation corrected. +! 2m air temperature + if(opt_sfc == 1 .or. opt_sfc ==2) then + ehb2 = fv*vkc/log((2.+z0h)/z0h) + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + if (parameters%urban_flag) q2b = qsfc + end if + +! update ch + ch = ehb + + end subroutine bare_flux + +!== begin ragrb ==================================================================================== + + subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out +! -------------------------------------------------------------------------------------------------- +! compute under-canopy aerodynamic resistance rag and leaf boundary layer +! resistance rb +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: vai !total lai + stem area index, one sided + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: hg !ground sensible heat flux (w/m2) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: tah !air temperature at height z0h+zpd (k) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: hcan !canopy height (m) [note: hcan >= z0mg] + real, intent(in) :: uc !wind speed at top of canopy (m/s) + real, intent(in) :: z0h !roughness length, sensible heat (m) + real, intent(in) :: z0hg !roughness length, sensible heat, ground (m) + real, intent(in) :: fv !friction velocity (m/s) + real, intent(in) :: cwp !canopy wind parameter + real, intent(in) :: mpe !prevents overflow error if division by zero + +! in & out + + real, intent(inout) :: mozg !monin-obukhov stability parameter + real, intent(inout) :: fhg !stability correction + +! outputs + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + real :: rb !bulk leaf boundary layer resistance (s/m) + + + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: tmp1 !temporary calculation + real :: tmp2 !temporary calculation + real :: tmprah2 !temporary calculation for aerodynamic resistances + real :: tmprb !temporary calculation for rb + real :: molg,fhgnew,cwpc +! -------------------------------------------------------------------------------------------------- +! stability correction to below canopy resistance + + mozg = 0. + molg = 0. + + if(iter > 1) then + tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + molg = -1. * fv**3 / tmp1 + mozg = min( (zpd-z0mg)/molg, 1.) + end if + + if (mozg < 0.) then + fhgnew = (1. - 15.*mozg)**(-0.25) + else + fhgnew = 1.+ 4.7*mozg + endif + + if (iter == 1) then + fhg = fhgnew + else + fhg = 0.5 * (fhg+fhgnew) + endif + + cwpc = (cwp * vai * hcan * fhg)**0.5 +! cwpc = (cwp*fhg)**0.5 + + tmp1 = exp( -cwpc*z0hg/hcan ) + tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) + tmprah2 = hcan*exp(cwpc) / cwpc * (tmp1-tmp2) + +! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. + + kh = max ( vkc*fv*(hcan-zpd), mpe ) + ramg = 0. + rahg = tmprah2 / kh + rawg = rahg + +! leaf boundary layer resistance + + tmprb = cwpc*50. / (1. - exp(-cwpc/2.)) + rb = tmprb * sqrt(parameters%dleaf/uc) +! rb = 200 + + end subroutine ragrb + +!== begin sfcdif1 ================================================================================== + + subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + & zlvl ,zpd ,z0m ,z0h ,ur , & !in + & mpe ,iloc ,jloc , & !in + & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + & cm ,ch ,fv ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: ur !wind speed (m/s) + real, intent(in) :: mpe !prevents overflow error if division by zero +! in & out + + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: moz !monin-obukhov stability (z/l) + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mol !monin-obukhov length (m) + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmp1,tmp2,tmp3,tmp4,tmp5 !temporary calculation + real :: tvir !temporary virtual temperature (k) + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical problem: zlvl <= zpd; model stops' + call wrf_error_fatal("stop in noah-mp") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1 + +!== begin sfcdif2 ================================================================================== + + subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in + zlm ,iloc ,jloc , & !in + akms ,akhs ,rlmo ,wstar2 , & !in + ustar ) !out + +! ------------------------------------------------------------------------------------------------- +! subroutine sfcdif (renamed sfcdif_off to avoid clash with eta pbl) +! ------------------------------------------------------------------------------------------------- +! calculate surface layer exchange coefficients via iterative process. +! see chen et al (1997, blm) +! ------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: iter + real, intent(in) :: zlm, z0, thz0, thlm, sfcspd + real, intent(inout) :: akms + real, intent(inout) :: akhs + real, intent(inout) :: rlmo + real, intent(inout) :: wstar2 + real, intent(out) :: ustar + + real zz, pslmu, pslms, pslhu, pslhs + real xx, pspmu, yy, pspms, psphu, psphs + real zilfc, zu, zt, rdz, cxch + real dthv, du2, btgh, zslu, zslt, rlogu, rlogt + real zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4 + + real xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, rlmn, & + & rlma + + integer ilech, itr + + integer, parameter :: itrmx = 5 + real, parameter :: wwst = 1.2 + real, parameter :: wwst2 = wwst * wwst + real, parameter :: vkrm = 0.40 + real, parameter :: excm = 0.001 + real, parameter :: beta = 1.0 / 270.0 + real, parameter :: btg = beta * grav + real, parameter :: elfc = vkrm * btg + real, parameter :: wold = 0.15 + real, parameter :: wnew = 1.0 - wold + real, parameter :: pihf = 3.14159265 / 2. + real, parameter :: epsu2 = 1.e-4 + real, parameter :: epsust = 0.07 + real, parameter :: epsit = 1.e-4 + real, parameter :: epsa = 1.e-8 + real, parameter :: ztmin = -5.0 + real, parameter :: ztmax = 1.0 + real, parameter :: hpbl = 1000.0 + real, parameter :: sqvisc = 258.2 + real, parameter :: ric = 0.183 + real, parameter :: rric = 1.0 / ric + real, parameter :: fhneu = 0.8 + real, parameter :: rfc = 0.191 + real, parameter :: rfac = ric / ( fhneu * rfc * rfc ) + +! ---------------------------------------------------------------------- +! note: the two code blocks below define functions +! ---------------------------------------------------------------------- +! lech's surface functions + pslmu (zz)= -0.96* log (1.0-4.5* zz) + pslms (zz)= zz * rric -2.076* (1. -1./ (zz +1.)) + pslhu (zz)= -0.96* log (1.0-4.5* zz) + pslhs (zz)= zz * rfac -2.076* (1. -1./ (zz +1.)) +! paulson's surface functions + pspmu (xx)= -2.* log ( (xx +1.)*0.5) - log ( (xx * xx +1.)*0.5) & + & +2.* atan (xx) & + &- pihf + pspms (yy)= 5.* yy + psphu (xx)= -2.* log ( (xx * xx +1.)*0.5) + psphs (yy)= 5.* yy + +! this routine sfcdif can handle both over open water (sea, ocean) and +! over solid surface (land, sea-ice). +! ---------------------------------------------------------------------- +! ztfc: ratio of zoh/zom less or equal than 1 +! c......ztfc=0.1 +! czil: constant c in zilitinkevich, s. s.1995,:note about zt +! ---------------------------------------------------------------------- + ilech = 0 + +! ---------------------------------------------------------------------- + zilfc = - parameters%czil * vkrm * sqvisc + zu = z0 + rdz = 1./ zlm + cxch = excm * rdz + dthv = thlm - thz0 + +! beljars correction of ustar + du2 = max (sfcspd * sfcspd,epsu2) + btgh = btg * hpbl + + if(iter == 1) then + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + rlmo = elfc * akhs * dthv / ustar **3 + end if + +! zilitinkevitch approach for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslu = zlm + zu + zslt = zlm + zt + rlogu = log (zslu / zu) + rlogt = log (zslt / zt) + +! ---------------------------------------------------------------------- +! 1./monin-obukkhov length-scale +! ---------------------------------------------------------------------- + zetalt = max (zslt * rlmo,ztmin) + rlmo = zetalt / zslt + zetalu = zslu * rlmo + zetau = zu * rlmo + zetat = zt * rlmo + + if (ilech .eq. 0) then + if (rlmo .lt. 0.)then + xlu4 = 1. -16.* zetalu + xlt4 = 1. -16.* zetalt + xu4 = 1. -16.* zetau + xt4 = 1. -16.* zetat + xlu = sqrt (sqrt (xlu4)) + xlt = sqrt (sqrt (xlt4)) + xu = sqrt (sqrt (xu4)) + + xt = sqrt (sqrt (xt4)) + psmz = pspmu (xu) + simm = pspmu (xlu) - psmz + rlogu + pshz = psphu (xt) + simh = psphu (xlt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pspms (zetau) + simm = pspms (zetalu) - psmz + rlogu + pshz = psphs (zetat) + simh = psphs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- +! lech's functions +! ---------------------------------------------------------------------- + else + if (rlmo .lt. 0.)then + psmz = pslmu (zetau) + simm = pslmu (zetalu) - psmz + rlogu + pshz = pslhu (zetat) + simh = pslhu (zetalt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pslms (zetau) + simm = pslms (zetalu) - psmz + rlogu + pshz = pslhs (zetat) + simh = pslhs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- + end if + +! ---------------------------------------------------------------------- +! beljaars correction for ustar +! ---------------------------------------------------------------------- + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + +! zilitinkevitch fix for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslt = zlm + zt +!----------------------------------------------------------------------- + rlogt = log (zslt / zt) + ustark = ustar * vkrm + akms = max (ustark / simm,cxch) +!----------------------------------------------------------------------- +! if statements to avoid tangent linear problems near zero +!----------------------------------------------------------------------- + akhs = max (ustark / simh,cxch) + + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if +!----------------------------------------------------------------------- + rlmn = elfc * akhs * dthv / ustar **3 +!----------------------------------------------------------------------- +! if(abs((rlmn-rlmo)/rlma).lt.epsit) go to 110 +!----------------------------------------------------------------------- + rlma = rlmo * wold+ rlmn * wnew +!----------------------------------------------------------------------- + rlmo = rlma + +! write(*,'(a20,10f15.6)')'sfcdif: rlmo=',rlmo,rlmn,elfc , akhs , dthv , ustar +! end do +! ---------------------------------------------------------------------- + end subroutine sfcdif2 + +!== begin esat ===================================================================================== + + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat + +!== begin stomata ================================================================================== + + subroutine stomata (parameters,vegtyp ,mpe ,apar ,foln ,iloc , jloc, & !in + tv ,ei ,ea ,sfctmp ,sfcprs , & !in + o2 ,co2 ,igs ,btran ,rb , & !in + rs ,psn ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation physiology type + + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: mpe !prevents division by zero errors + + real, intent(in) :: tv !foliage temperature (k) + real, intent(in) :: ei !vapor pressure inside leaf (sat vapor press at tv) (pa) + real, intent(in) :: ea !vapor pressure of canopy air (pa) + real, intent(in) :: apar !par absorbed per unit lai (w/m2) + real, intent(in) :: o2 !atmospheric o2 concentration (pa) + real, intent(in) :: co2 !atmospheric co2 concentration (pa) + real, intent(in) :: sfcprs !air pressure at reference height (pa) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: foln !foliage nitrogen concentration (%) + real, intent(in) :: rb !boundary layer resistance (s/m) + +! output + real, intent(out) :: rs !leaf stomatal resistance (s/m) + real, intent(out) :: psn !foliage photosynthesis (umol co2 /m2/ s) [always +] + +! in&out + real :: rlb !boundary layer resistance (s m2 / umol) +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: iter !iteration index + integer :: niter !number of iterations + + data niter /3/ + save niter + + real :: ab !used in statement functions + real :: bc !used in statement functions + real :: f1 !generic temperature response (statement function) + real :: f2 !generic temperature inhibition (statement function) + real :: tc !foliage temperature (degree celsius) + real :: cs !co2 concentration at leaf surface (pa) + real :: kc !co2 michaelis-menten constant (pa) + real :: ko !o2 michaelis-menten constant (pa) + real :: a,b,c,q !intermediate calculations for rs + real :: r1,r2 !roots for rs + real :: fnf !foliage nitrogen adjustment factor (0 to 1) + real :: ppf !absorb photosynthetic photon flux (umol photons/m2/s) + real :: wc !rubisco limited photosynthesis (umol co2/m2/s) + real :: wj !light limited photosynthesis (umol co2/m2/s) + real :: we !export limited photosynthesis (umol co2/m2/s) + real :: cp !co2 compensation point (pa) + real :: ci !internal co2 (pa) + real :: awc !intermediate calculation for wc + real :: vcmx !maximum rate of carbonylation (umol co2/m2/s) + real :: j !electron transport (umol co2/m2/s) + real :: cea !constrain ea or else model blows up + real :: cf !s m2/umol -> s/m + + f1(ab,bc) = ab**((bc-25.)/10.) + f2(ab) = 1. + exp((-2.2e05+710.*(ab+273.16))/(8.314*(ab+273.16))) + real :: t +! --------------------------------------------------------------------------------------------- + +! initialize rs=rsmax and psn=0 because will only do calculations +! for apar > 0, in which case rs <= rsmax and psn >= 0 + + cf = sfcprs/(8.314*sfctmp)*1.e06 + rs = 1./parameters%bp * cf + psn = 0. + + if (apar .le. 0.) return + + fnf = min( foln/max(mpe,parameters%folnmx), 1.0 ) + tc = tv-tfrz + ppf = 4.6*apar + j = ppf*parameters%qe25 + kc = parameters%kc25 * f1(parameters%akc,tc) + ko = parameters%ko25 * f1(parameters%ako,tc) + awc = kc * (1.+o2/ko) + cp = 0.5*kc/ko*o2*0.21 + vcmx = parameters%vcmx25 / f2(tc) * fnf * btran * f1(parameters%avcmx,tc) + +! first guess ci + + ci = 0.7*co2*parameters%c3psn + 0.4*co2*(1.-parameters%c3psn) + +! rb: s/m -> s m**2 / umol + + rlb = rb/cf + +! constrain ea + + cea = max(0.25*ei*parameters%c3psn+0.40*ei*(1.-parameters%c3psn), min(ea,ei) ) + +! ci iteration +!jref: c3psn is equal to 1 for all veg types. + do iter = 1, niter + wj = max(ci-cp,0.)*j/(ci+2.*cp)*parameters%c3psn + j*(1.-parameters%c3psn) + wc = max(ci-cp,0.)*vcmx/(ci+awc)*parameters%c3psn + vcmx*(1.-parameters%c3psn) + we = 0.5*vcmx*parameters%c3psn + 4000.*vcmx*ci/sfcprs*(1.-parameters%c3psn) + psn = min(wj,wc,we) * igs + + cs = max( co2-1.37*rlb*sfcprs*psn, mpe ) + a = parameters%mp*psn*sfcprs*cea / (cs*ei) + parameters%bp + b = ( parameters%mp*psn*sfcprs/cs + parameters%bp ) * rlb - 1. + c = -rlb + if (b .ge. 0.) then + q = -0.5*( b + sqrt(b*b-4.*a*c) ) + else + q = -0.5*( b - sqrt(b*b-4.*a*c) ) + end if + r1 = q/a + r2 = c/q + rs = max(r1,r2) + ci = max( cs-psn*sfcprs*1.65*rs, 0. ) + end do + +! rs, rb: s m**2 / umol -> s/m + + rs = rs*cf + + end subroutine stomata + +!== begin canres =================================================================================== + + subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in + rc ,psn ,iloc ,jloc ) !out + +! -------------------------------------------------------------------------------------------------- +! calculate canopy resistance which depends on incoming solar radiation, +! air temperature, atmospheric water vapor pressure deficit at the +! lowest model level, and soil moisture (preferably unfrozen soil +! moisture rather than total) +! -------------------------------------------------------------------------------------------------- +! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin and +! noilhan (1990, blm). chen et al (1996, jgr, vol 101(d3), 7251-7268), +! eqns 12-14 and table 2 of sec. 3.1.2 +! -------------------------------------------------------------------------------------------------- +!niu use module_noahlsm_utility +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + real, intent(in) :: par !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: sfctmp !canopy air temperature + real, intent(in) :: sfcprs !surface pressure (pa) + real, intent(in) :: eah !water vapor pressure (pa) + real, intent(in) :: rcsoil !soil moisture stress factor + +!outputs + + real, intent(out) :: rc !canopy resistance per unit lai + real, intent(out) :: psn !foliage photosynthesis (umolco2/m2/s) + +!local + + real :: rcq + real :: rcs + real :: rct + real :: ff + real :: q2 !water vapor mixing ratio (kg/kg) + real :: q2sat !saturation q2 + real :: dqsdt2 !d(q2sat)/d(t) + +! rsmin, rsmax, topt, rgl, hs are canopy stress parameters set in redprm +! ---------------------------------------------------------------------- +! initialize canopy resistance multiplier terms. +! ---------------------------------------------------------------------- + rc = 0.0 + rcs = 0.0 + rct = 0.0 + rcq = 0.0 + +! compute q2 and q2sat + + q2 = 0.622 * eah / (sfcprs - 0.378 * eah) !specific humidity [kg/kg] + q2 = q2 / (1.0 + q2) !mixing ratio [kg/kg] + + call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + +! contribution due to incoming solar radiation + + ff = 2.0 * par / parameters%rgl + rcs = (ff + parameters%rsmin / parameters%rsmax) / (1.0+ ff) + rcs = max (rcs,0.0001) + +! contribution due to air temperature + + rct = 1.0- 0.0016* ( (parameters%topt - sfctmp)**2.0) + rct = max (rct,0.0001) + +! contribution due to vapor pressure deficit + + rcq = 1.0/ (1.0+ parameters%hs * max(0.,q2sat-q2)) + rcq = max (rcq,0.01) + +! determine canopy resistance due to all factors + + rc = parameters%rsmin / (rcs * rct * rcq * rcsoil) + psn = -999.99 ! psn not applied for dynamic carbon + + end subroutine canres + +!== begin calhum =================================================================================== + + subroutine calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + + implicit none + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sfctmp, sfcprs + real, intent(out) :: q2sat, dqsdt2 + real, parameter :: a2=17.67,a3=273.15,a4=29.65, elwv=2.501e6, & + a23m4=a2*(a3-a4), e0=0.611, rv=461.0, & + epsilon=0.622 + real :: es, sfcprsx + +! q2sat: saturated mixing ratio + es = e0 * exp ( elwv/rv*(1./a3 - 1./sfctmp) ) +! convert sfcprs from pa to kpa + sfcprsx = sfcprs*1.e-3 + q2sat = epsilon * es / (sfcprsx-es) +! convert from g/g to g/kg + q2sat = q2sat * 1.e3 +! q2sat is currently a 'mixing ratio' + +! dqsdt2 is calculated assuming q2sat is a specific humidity + dqsdt2=(q2sat/(1+q2sat))*a23m4/(sfctmp-a4)**2 + +! dg q2sat needs to be in g/g when returned for sflx + q2sat = q2sat / 1.e3 + + end subroutine calhum + +!== begin tsnosoi ================================================================================== + + subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: ice ! + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + integer, intent(in) :: ist !surface type + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: sag !solar rad. absorbed by ground (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + + real, dimension(-nsnow+1:nsoil) :: tbeg + real :: err_est !heat storage error (w/m2) + real :: ssoil2 !ground heat flux (w/m2) (for energy check) + real :: eflxb2 !heat flux from the bottom (w/m2) (for energy check) + character(len=256) :: message +! ---------------------------------------------------------------------- +! compute solar penetration through water, needs more work + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = parameters%zbot - snowh !from snow surface + +! snow/soil heat storage for energy balance check + + do iz = isnow+1, nsoil + tbeg(iz) = stc(iz) + enddo + +! compute soil temperatures + + call hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + +! update ground heat flux just for energy check, but not for final output +! otherwise, it would break the surface energy balance + + if(opt_tbot == 1) then + eflxb2 = 0. + else if(opt_tbot == 2) then + eflxb2 = df(nsoil)*(tbot-stc(nsoil)) / & + (0.5*(zsnso(nsoil-1)+zsnso(nsoil)) - zbotsno) + end if + + ! skip the energy balance check for now, until we can make it work + ! right for small time steps. + return + +! energy balance check + + err_est = 0.0 + do iz = isnow+1, nsoil + err_est = err_est + (stc(iz)-tbeg(iz)) * dzsnso(iz) * hcpct(iz) / dt + enddo + + if (opt_stc == 1) then ! semi-implicit + err_est = err_est - (ssoil +eflxb) + else ! full-implicit + ssoil2 = df(isnow+1)*(tg-stc(isnow+1))/(0.5*dzsnso(isnow+1)) !m. barlage + err_est = err_est - (ssoil2+eflxb2) + endif + + if (abs(err_est) > 1.) then ! w/m2 + write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2' + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') & + iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb + call wrf_message(trim(message)) + !niu stop + end if + + end subroutine tsnosoi + +!== begin hrt ====================================================================================== + + subroutine hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbot ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + botflx ) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: dt !time step (s) + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: dz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt + +!== begin hstep ==================================================================================== + + subroutine hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + + call rosr12 (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep + +!== begin rosr12 =================================================================================== + + subroutine rosr12 (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12 + +!== begin phasechange ============================================================================== + + subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + integer, intent(in) :: ist !surface type: 1->soil; 2->lake + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: qmelt !snowmelt rate [mm/s] + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! inputs and outputs + + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: j !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: supercool !supercooled water in soil (kg/m2) + real :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: smp !frozen water potential (mm) + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = -nsnow+1, nsoil + supercool(j) = 0.0 + end do + + do j = isnow+1,0 ! all layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! soil + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + if(ist == 1) then + do j = 1,nsoil + if (opt_frz == 1) then + if(stc(j) < tfrz) then + smp = hfus*(tfrz-stc(j))/(grav*stc(j)) !(m) + supercool(j) = parameters%smcmax*(smp/parameters%psisat)**(-1./parameters%bexp) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + end if + if (opt_frz == 2) then + call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j)) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + enddo + end if + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then !melting + imelt(j) = 1 + endif + if (mliq(j) > supercool(j) .and. stc(j) < tfrz) then + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr > 0.) then + xm(1) = heatr*dt/hfus + hm(1) = heatr + else + xm(1) = 0. + hm(1) = 0. + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + if (j <= 0) then ! snow + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + else ! soil + if (wmass0(j) < supercool(j)) then + mice(j) = 0. + else + mice(j) = min(wmass0(j) - supercool(j),wice0(j)-xm(j)) + mice(j) = max(mice(j),0.0) + endif + endif + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr) > 0.) then + stc(j) = stc(j) + fact(j)*heatr + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + end do + + end subroutine phasechange + +!== begin frh2o ==================================================================================== + + subroutine frh2o (parameters,free,tkelv,smc,sh2o) + +! ---------------------------------------------------------------------- +! subroutine frh2o +! ---------------------------------------------------------------------- +! calculate amount of supercooled liquid soil water content if +! temperature is below 273.15k (tfrz). requires newton-type iteration +! to solve the nonlinear implicit equation given in eqn 17 of koren et al +! (1999, jgr, vol 104(d16), 19569-19585). +! ---------------------------------------------------------------------- +! new version (june 2001): much faster and more accurate newton +! iteration achieved by first taking log of eqn cited above -- less than +! 4 (typically 1 or 2) iterations achieves convergence. also, explicit +! 1-step solution option for special case of parameter ck=0, which +! reduces the original implicit equation to a simpler explicit form, +! known as the "flerchinger eqn". improved handling of solution in the +! limit of freezing point temperature tfrz. +! ---------------------------------------------------------------------- +! input: + +! tkelv.........temperature (kelvin) +! smc...........total soil moisture content (volumetric) +! sh2o..........liquid soil moisture content (volumetric) +! b.............soil type "b" parameter (from redprm) +! psisat........saturated soil matric potential (from redprm) + +! output: +! free..........supercooled liquid water content [m3/m3] +! ---------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sh2o,smc,tkelv + real, intent(out) :: free + real :: bx,denom,df,dswl,fk,swl,swlk + integer :: nlog,kcount +! parameter(ck = 0.0) + real, parameter :: ck = 8.0, blim = 5.5, error = 0.005, & + dice = 920.0 + character(len=80) :: message + +! ---------------------------------------------------------------------- +! limits on parameter b: b < 5.5 (use parameter blim) +! simulations showed if b > 5.5 unfrozen water content is +! non-realistically high at very low temperatures. +! ---------------------------------------------------------------------- + bx = parameters%bexp +! ---------------------------------------------------------------------- +! initializing iterations counter and iterative solution flag. +! ---------------------------------------------------------------------- + + if (parameters%bexp > blim) bx = blim + nlog = 0 + +! ---------------------------------------------------------------------- +! if temperature not significantly below freezing (tfrz), sh2o = smc +! ---------------------------------------------------------------------- + kcount = 0 + if (tkelv > (tfrz- 1.e-3)) then + free = smc + else + +! ---------------------------------------------------------------------- +! option 1: iterated solution in koren et al, jgr, 1999, eqn 17 +! ---------------------------------------------------------------------- +! initial guess for swl (frozen content) +! ---------------------------------------------------------------------- + if (ck /= 0.0) then + swl = smc - sh2o +! ---------------------------------------------------------------------- +! keep within bounds. +! ---------------------------------------------------------------------- + if (swl > (smc -0.02)) swl = smc -0.02 +! ---------------------------------------------------------------------- +! start of iterations +! ---------------------------------------------------------------------- + if (swl < 0.) swl = 0. +1001 continue + if (.not.( (nlog < 10) .and. (kcount == 0))) goto 1002 + nlog = nlog +1 + df = alog ( ( parameters%psisat * grav / hfus ) * ( ( 1. + ck * swl )**2.) * & + ( parameters%smcmax / (smc - swl) )** bx) - alog ( - ( & + tkelv - tfrz)/ tkelv) + denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl ) + swlk = swl - df / denom +! ---------------------------------------------------------------------- +! bounds useful for mathematical solution. +! ---------------------------------------------------------------------- + if (swlk > (smc -0.02)) swlk = smc - 0.02 + if (swlk < 0.) swlk = 0. + +! ---------------------------------------------------------------------- +! mathematical solution bounds applied. +! ---------------------------------------------------------------------- + dswl = abs (swlk - swl) +! if more than 10 iterations, use explicit method (ck=0 approx.) +! when dswl less or eq. error, no more iterations required. +! ---------------------------------------------------------------------- + swl = swlk + if ( dswl <= error ) then + kcount = kcount +1 + end if +! ---------------------------------------------------------------------- +! end of iterations +! ---------------------------------------------------------------------- +! bounds applied within do-block are valid for physical solution. +! ---------------------------------------------------------------------- + goto 1001 +1002 continue + free = smc - swl + end if +! ---------------------------------------------------------------------- +! end option 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! option 2: explicit solution for flerchinger eq. i.e. ck=0 +! in koren et al., jgr, 1999, eqn 17 +! apply physical bounds to flerchinger solution +! ---------------------------------------------------------------------- + if (kcount == 0) then + write(message, '("flerchinger used in new version. iterations=", i6)') nlog + call wrf_message(trim(message)) + fk = ( ( (hfus / (grav * ( - parameters%psisat)))* & + ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax + if (fk < 0.02) fk = 0.02 + free = min (fk, smc) +! ---------------------------------------------------------------------- +! end option 2 +! ---------------------------------------------------------------------- + end if + end if +! ---------------------------------------------------------------------- + end subroutine frh2o +! ---------------------------------------------------------------------- +! ================================================================================================== +! **********************end of energy subroutines*********************** +! ================================================================================================== + +!== begin water ==================================================================================== + + subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in + bdfall ,fp ,rain ,snow, & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2, & + qsnbot ,esnow) +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: ist !surface type 1-soil; 2-lake + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ to atm ] + real, intent(in) :: fctr !transpiration (w/m2) [+ to atm] + real, intent(in) :: qprecc !convective precipitation (mm/s) + real, intent(in) :: qprecl !large-scale precipitation (mm/s) + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension( 1:nsoil), intent(in) :: btrani !soil water stress factor (0 to 1) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep +! real , intent(in) :: ponding ![mm] + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + real , intent(in) :: fp !fraction of the gridcell that receives precipitation ! mb/an: v3.7 + real , intent(in) :: rain !rainfall (mm/s) ! mb/an: v3.7 + real , intent(in) :: snow !snowfall (mm/s) ! mb/an: v3.7 + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + real , intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real , intent(in) :: qrain !rain at ground srf (mm) [+] + real , intent(in) :: snowhin !snow depth increasing rate (m/s) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ stuarated soil [mm] + real, intent(inout) :: wslake !water storage in lake (can be -) (mm) + real , intent(inout) :: ponding ![mm] + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real, intent(out) :: cmc !intercepted water per ground area (mm) + real, intent(out) :: ecan !evap of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted/snowed fraction of canopy (-) + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: esnow + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real , intent(in) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(in) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(in) :: frozen_ground ! used to define latent heat pathway + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + + +! local + integer :: iz + real :: qinsur !water input on soil surface [m/s] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real, dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+] + real, dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s) + real :: qdrain !soil-bottom free drainage [mm/s] + real :: snoflow !glacier flow [mm/s] + real :: fcrmax !maximum of fcr (-) + + real, parameter :: wslmax = 5000. !maximum lake water storage (mm) + + +! ---------------------------------------------------------------------- +! initialize + + etrani(1:nsoil) = 0. + snoflow = 0. + runsub = 0. + qinsur = 0. + +! canopy-intercepted snowfall/rainfall, drips, and throughfall + + call canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc, & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! sublimation, frost, evaporation, and dew + + qsnsub = 0. + if (sneqv > 0.) then + qsnsub = min(qvap, sneqv/dt) + endif + qseva = qvap-qsnsub + esnow = qsnsub*2.83e+6 + + qsnfro = 0. + if (sneqv > 0.) then + qsnfro = qdew + endif + qsdew = qdew - qsnfro + + call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + & qrain ,ficeold,iloc ,jloc , & !in + & isnow ,snowh ,sneqv ,snice ,snliq , & !inout + & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + & qsnbot ,snoflow,ponding1 ,ponding2) !out + + if(frozen_ground) then + sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.) + qsdew = 0.0 + qseva = 0.0 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! convert units (mm/s -> m/s) + + !ponding: melting water from snow when there is no layer + qinsur = (ponding+ponding1+ponding2)/dt * 0.001 +! qinsur = ponding/dt * 0.001 + + if(isnow == 0) then + qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001 + else + qinsur = qinsur+(qsnbot + qsdew) * 0.001 + endif + + qseva = qseva * 0.001 + + do iz = 1, parameters%nroot + etrani(iz) = etran * btrani(iz) * 0.001 + enddo + + +! lake/soil water balances + + if (ist == 2) then ! lake + runsrf = 0. + if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s + wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm + else ! soil + call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in + sh2o ,smc ,zwt ,vegtyp , & !inout + smcwtd, deeprech , & !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + + if(opt_run == 1) then + call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out + runsub = qdis !mm/s + end if + + if(opt_run == 3 .or. opt_run == 4) then + runsub = runsub + qdrain !mm/s + end if + + do iz = 1,nsoil + smc(iz) = sh2o(iz) + sice(iz) + enddo + + if(opt_run == 5) then + call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in + dzsnso ,smceq ,iloc , jloc , & !in + smc ,zwt ,smcwtd ,rech, qdrain ) !inout + + sh2o(nsoil) = smc(nsoil) - sice(nsoil) + runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here + wa = 0. + endif + + endif + + runsub = runsub + snoflow !mm/s + + end subroutine water + +!== begin canwater ================================================================================= + + subroutine canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc , & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! ------------------------ code history ------------------------------ +! canopy hydrology +! -------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + real, intent(in) :: dt !main time step (s) + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ = to atm] + real, intent(in) :: fctr !transpiration (w/m2) [+ = to atm] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: fveg !greeness vegetation fraction (-) + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + +! output + real, intent(out) :: cmc !intercepted water (mm) + real, intent(out) :: ecan !evaporation of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: qevac !evaporation rate (mm/s) + real :: qdewc !dew rate (mm/s) + real :: qfroc !frost rate (mm/s) + real :: qsubc !sublimation rate (mm/s) + real :: qmeltc !melting rate of canopy snow (mm/s) + real :: qfrzc !refreezing rate of canopy liquid water (mm/s) + real :: canmas !total canopy mass (kg/m2) +! -------------------------------------------------------------------- +! initialization + + ecan = 0.0 + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! evaporation, transpiration, and dew + + if (.not.frozen_canopy) then ! barlage: change to frozen_canopy + etran = max( fctr/hvap, 0. ) + qevac = max( fcev/hvap, 0. ) + qdewc = abs( min( fcev/hvap, 0. ) ) + qsubc = 0. + qfroc = 0. + else + etran = max( fctr/hsub, 0. ) + qevac = 0. + qdewc = 0. + qsubc = max( fcev/hsub, 0. ) + qfroc = abs( min( fcev/hsub, 0. ) ) + endif + +! canopy water balance. for convenience allow dew to bring canliq above +! maxh2o or else would have to re-adjust drip + + qevac = min(canliq/dt,qevac) + canliq=max(0.,canliq+(qdewc-qevac)*dt) + if(canliq <= 1.e-06) canliq = 0.0 + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + qsubc = min(canice/dt,qsubc) + canice= max(0.,canice + (qfroc-qsubc)*dt) + if(canice.le.1.e-6) canice = 0. + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! phase change + + qmeltc = 0. + qfrzc = 0. + + if(canice.gt.1.e-6.and.tv.gt.tfrz) then + qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus)) + canice = max(0.,canice - qmeltc*dt) + canliq = max(0.,canliq + qmeltc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + + if(canliq.gt.1.e-6.and.tv.lt.tfrz) then + qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus)) + canliq = max(0.,canliq - qfrzc*dt) + canice = max(0.,canice + qfrzc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + +! total canopy water + + cmc = canliq + canice + +! total canopy evaporation + + ecan = qevac + qsubc - qdewc - qfroc + + end subroutine canwater + +!== begin snowwater ================================================================================ + + subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + qrain ,ficeold,iloc ,jloc , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz,i + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + +! mb: do each if block separately + + if(isnow < 0) & ! when multi-layer + call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in + isnow ,dzsnso ,zsnso ) !inout + + if(isnow < 0) & !when multi-layer + call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + if(isnow < 0) & !when multi-layer + call divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + + call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow < 0) then ! mb: only do for multi-layer + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater + +!== begin snowfall ================================================================================= + + subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit +! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall + +!== begin combine ================================================================================== + + subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + + real :: dzmin(3) ! minimum of top snow layer +! data dzmin /0.045, 0.05, 0.2/ + data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then ! mb/km: change to isnow + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + if(snice(j) >= 0.) then + ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get + sneqv = snice(j) ! added to ponding from phasechange ponding should be + snowh = dzsnso(j) ! zero here because it was calculated for thin snow + else ! snice over-sublimated earlier + ponding1 = snliq(j) + snice(j) + if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil + sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.)) + ponding1 = 0.0 + end if + sneqv = 0.0 + snowh = 0.0 + end if + snliq(j) = 0.0 + snice(j) = 0.0 + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + + if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit +! if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo (parameters,dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine + +!== begin divide =================================================================================== + + subroutine divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer + if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit +! if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide + +!== begin combo ==================================================================================== + + subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo + +!== begin compact ================================================================================== + + subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in + isnow ,dzsnso ,zsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil srf + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso ! depth of snow/soil layer-bottom + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact + +!== begin snowh2o ================================================================================== + + subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp + real :: ponding1, ponding2 +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !out + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - parameters%ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o + +!== begin soilwater ================================================================================ + + subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in + sh2o ,smc ,zwt ,vegtyp ,& !inout + smcwtd, deeprech ,& !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + +! ---------------------------------------------------------------------- +! calculate surface runoff and soil moisture. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !time step (sec) + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: qseva !evap from soil surface [mm/s] + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: etrani !evapotranspiration from soil layers [mm/s] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + + integer, intent(in) :: vegtyp + +! input & output + real, dimension(1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !water table depth [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real , intent(inout) :: deeprech + +! output + real, intent(out) :: qdrain !soil-bottom free drainage [mm/s] + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !subsurface runoff [mm/s] + real, intent(out) :: fcrmax !maximum of fcr (-) + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + +! local + integer :: k,iz !do-loop index + integer :: iter !iteration index + real :: dtfine !fine time step (s) + real, dimension(1:nsoil) :: rhstt !right-hand side term of the matrix + real, dimension(1:nsoil) :: ai !left-hand side term + real, dimension(1:nsoil) :: bi !left-hand side term + real, dimension(1:nsoil) :: ci !left-hand side term + + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + real :: pddum !infiltration rate at surface (m/s) + real :: fice !ice fraction in frozen soil + real :: wplus !saturation excess of the total soil [m] + real :: rsat !accumulation of wplus (saturation excess) [m] + real :: sicemax!maximum soil ice content (m3/m3) + real :: sh2omin!minimum soil liquid water content (m3/m3) + real :: wtsub !sum of wcnd(k)*dzsnso(k) + real :: mh2o !water mass removal (mm) + real :: fsat !fractional saturated area (-) + real, dimension(1:nsoil) :: mliq ! + real :: xs ! + real :: watmin ! + real :: qdrain_save ! + real :: epore !effective porosity [m3/m3] + real, dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil + integer :: niter !iteration times soil moisture (-) + real :: smctot !2-m averaged soil moisture (m3/m3) + real :: dztot !2-m soil depth (m) + real, parameter :: a = 4.0 +! ---------------------------------------------------------------------- + runsrf = 0.0 + pddum = 0.0 + rsat = 0.0 + +! for the case when snowmelt water is too large + + do k = 1,nsoil + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + end do + +!impermeable fraction due to frozen soil + + do k = 1,nsoil + fice = min(1.0,sice(k)/parameters%smcmax) + fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / & + (1.0 - exp(-a)) + end do + +! maximum soil ice content and minimum liquid water of all layers + + sicemax = 0.0 + fcrmax = 0.0 + sh2omin = parameters%smcmax + do k = 1,nsoil + if (sice(k) > sicemax) sicemax = sice(k) + if (fcr(k) > fcrmax) fcrmax = fcr(k) + if (sh2o(k) < sh2omin) sh2omin = sh2o(k) + end do + +!subsurface runoff for runoff scheme option 2 + + if(opt_run == 2) then + fff = 2.0 + rsbmx = 4.0 + call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) + runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s + end if + +!surface runoff and infiltration rate using different schemes + +!jref impermable surface at urban + if ( parameters%urban_flag ) fcr(1)= 0.95 + + if(opt_run == 1) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 5) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 2) then + fff = 2.0 + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 3) then + call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out + end if + + if(opt_run == 4) then + smctot = 0. + dztot = 0. + do k = 1,nsoil + dztot = dztot + dzsnso(k) + smctot = smctot + smc(k)*dzsnso(k) + if(dztot >= 2.0) exit + end do + smctot = smctot/dztot + fsat = max(0.01,smctot/parameters%smcmax) ** 4. !bats + + if(qinsur > 0.) then + runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1)) + pddum = qinsur - runsrf ! m/s + end if + end if + +! determine iteration times and finer time step + + niter = 1 + + if(opt_inf == 1) then !opt_inf =2 may cause water imbalance + niter = 3 + if (pddum*dt>dzsnso(1)*parameters%smcmax ) then + niter = niter*2 + end if + end if + + dtfine = dt / niter + +! solve soil moisture + + qdrain_save = 0.0 + do iter = 1, niter + call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out + + call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus) !out + rsat = rsat + wplus + qdrain_save = qdrain_save + qdrain + end do + + qdrain = qdrain_save/niter + + runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s + qdrain = qdrain * 1000. + +!wrf_hydro_djg... +!yw infxsrt = runsrf * dt !mm/s -> mm + +! removal of soil water due to groundwater flow (option 2) + + if(opt_run == 2) then + wtsub = 0. + do k = 1, nsoil + wtsub = wtsub + wcnd(k)*dzsnso(k) + end do + + do k = 1, nsoil + mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm + sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.) + end do + end if + +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. + + if(opt_run /= 1) then + do iz = 1, nsoil + mliq(iz) = sh2o(iz)*dzsnso(iz)*1000. + end do + + watmin = 0.01 ! mm + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + runsub = runsub - xs/dt + if(opt_run == 5)deeprech = deeprech - xs*1.e-3 + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.) + end do + end if + + end subroutine soilwater + +!== begin zwteq ==================================================================================== + + subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) +! ---------------------------------------------------------------------- +! calculate equilibrium water table depth (niu et al., 2005) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + +! output + + real, intent(out) :: zwt !water table depth [m] + +! locals + + integer :: k !do-loop index + integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil + real :: wd1 !water deficit from coarse (4-l) soil moisture profile + real :: wd2 !water deficit from fine (100-l) soil moisture profile + real :: dzfine !layer thickness of the 100-l soil layers to 6.0 m + real :: temp !temporary variable + real, dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m +! ---------------------------------------------------------------------- + + wd1 = 0. + do k = 1,nsoil + wd1 = wd1 + (parameters%smcmax-sh2o(k)) * dzsnso(k) ! [m] + enddo + + dzfine = 3.0 * (-zsoil(nsoil)) / nfine + do k =1,nfine + zfine(k) = float(k) * dzfine + enddo + + zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m] + + wd2 = 0. + do k = 1,nfine + temp = 1. + (zwt-zfine(k))/parameters%psisat + wd2 = wd2 + parameters%smcmax*(1.-temp**(-1./parameters%bexp))*dzfine + if(abs(wd2-wd1).le.0.01) then + zwt = zfine(k) + exit + endif + enddo + + end subroutine zwteq + +!== begin infil ==================================================================================== + + subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out +! -------------------------------------------------------------------------------- +! compute inflitration rate at soil surface and surface runoff +! -------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !time step (sec) + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + +! outputs + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: pddum !infiltration rate at surface + +! locals + integer :: ialp1, j, jj, k + real :: val + real :: ddt + real :: px + real :: dt1, dd, dice + real :: fcr + real :: sum + real :: acrt + real :: wdf + real :: wcnd + real :: smcav + real :: infmax + real, dimension(1:nsoil) :: dmax + integer, parameter :: cvfrz = 3 +! -------------------------------------------------------------------------------- + + if (qinsur > 0.0) then + dt1 = dt /86400. + smcav = parameters%smcmax - parameters%smcwlt + +! maximum infiltration rate + + dmax(1)= -zsoil(1) * smcav + dice = -zsoil(1) * sice(1) + dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt)/smcav) + + dd = dmax(1) + + do k = 2,nsoil + dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k) + dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav + dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt)/smcav) + dd = dd + dmax(k) + end do + + val = (1. - exp ( - parameters%kdt * dt1)) + ddt = dd * val + px = max(0.,qinsur * dt) + infmax = (px * (ddt / (px + ddt)))/ dt + +! impermeable fraction due to frozen soil + + fcr = 1. + if (dice > 1.e-2) then + acrt = cvfrz * parameters%frzx / dice + sum = 1. + ialp1 = cvfrz - 1 + do j = 1,ialp1 + k = 1 + do jj = j +1,ialp1 + k = k * jj + end do + sum = sum + (acrt ** (cvfrz - j)) / float(k) + end do + fcr = 1. - exp (-acrt) * sum + end if + +! correction of infiltration limitation + + infmax = infmax * fcr + +! jref for urban areas +! if ( parameters%urban_flag ) infmax == infmax * 0.05 + + call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax) + infmax = max (infmax,wcnd) + infmax = min (infmax,px) + + runsrf= max(0., qinsur - infmax) + pddum = qinsur - runsrf + + end if + + end subroutine infil + +!== begin srt ====================================================================================== + + subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! water diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil + real, dimension(1:nsoil), intent(in) :: zsoil + real, intent(in) :: dt + real, intent(in) :: pddum + real, intent(in) :: qseva + real, dimension(1:nsoil), intent(in) :: etrani + real, dimension(1:nsoil), intent(in) :: sh2o + real, dimension(1:nsoil), intent(in) :: smc + real, intent(in) :: zwt ! water table depth [m] + real, dimension(1:nsoil), intent(in) :: fcr + real, intent(in) :: fcrmax !maximum of fcr (-) + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + real, intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table + +! output + + real, dimension(1:nsoil), intent(out) :: rhstt + real, dimension(1:nsoil), intent(out) :: ai + real, dimension(1:nsoil), intent(out) :: bi + real, dimension(1:nsoil), intent(out) :: ci + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + real, intent(out) :: qdrain !bottom drainage (m/s) + +! local + integer :: k + real, dimension(1:nsoil) :: ddz + real, dimension(1:nsoil) :: denom + real, dimension(1:nsoil) :: dsmdz + real, dimension(1:nsoil) :: wflux + real, dimension(1:nsoil) :: wdf + real, dimension(1:nsoil) :: smx + real :: temp1 + real :: smxwtd !soil moisture between bottom of the soil and water table + real :: smxbot !soil moisture below bottom to calculate flux + +! niu and yang (2006), j. of hydrometeorology +! ---------------------------------------------------------------------- + + if(opt_inf == 1) then + do k = 1, nsoil + call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k)) + smx(k) = smc(k) + end do + if(opt_run == 5)smxwtd=smcwtd + end if + + if(opt_inf == 2) then + do k = 1, nsoil + call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax) + smx(k) = sh2o(k) + end do + if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer + end if + + do k = 1, nsoil + if(k == 1) then + denom(k) = - zsoil (k) + temp1 = - zsoil (k+1) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva + else if (k < nsoil) then + denom(k) = (zsoil(k-1) - zsoil(k)) + temp1 = (zsoil(k-1) - zsoil(k+1)) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) & + - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k) + else + denom(k) = (zsoil(k-1) - zsoil(k)) + if(opt_run == 1 .or. opt_run == 2) then + qdrain = 0. + end if + if(opt_run == 3) then + qdrain = parameters%slope*wcnd(k) + end if + if(opt_run == 4) then + qdrain = (1.0-fcrmax)*wcnd(k) + end if + if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation + temp1 = 2.0 * denom(k) + if(zwt < zsoil(nsoil)-denom(nsoil))then +!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom + smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt) + else + smxbot = smxwtd + endif + dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1 + qdrain = wdf(k ) * dsmdz(k ) + wcnd(k ) + end if + wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain + end if + end do + + do k = 1, nsoil + if(k == 1) then + ai(k) = 0.0 + bi(k) = wdf(k ) * ddz(k ) / denom(k) + ci(k) = - bi (k) + else if (k < nsoil) then + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = - wdf(k ) * ddz(k ) / denom(k) + bi(k) = - ( ai (k) + ci (k) ) + else + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - ( ai (k) + ci (k) ) + end if + rhstt(k) = wflux(k) / (-denom(k)) + end do + +! ---------------------------------------------------------------------- + end subroutine srt + +!== begin sstep ==================================================================================== + + subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus ) !out + +! ---------------------------------------------------------------------- +! calculate/update soil moisture content values +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil ! + integer, intent(in) :: nsnow ! + real, intent(in) :: dt + real, intent(in) :: zwt + real, dimension( 1:nsoil), intent(in) :: zsoil + real, dimension( 1:nsoil), intent(in) :: sice + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + +!input and output + real, dimension(1:nsoil), intent(inout) :: sh2o + real, dimension(1:nsoil), intent(inout) :: smc + real, dimension(1:nsoil), intent(inout) :: ai + real, dimension(1:nsoil), intent(inout) :: bi + real, dimension(1:nsoil), intent(inout) :: ci + real, dimension(1:nsoil), intent(inout) :: rhstt + real , intent(inout) :: smcwtd + real , intent(inout) :: qdrain + real , intent(inout) :: deeprech + +!output + real, intent(out) :: wplus !saturation excess water (m) + +!local + integer :: k + real, dimension(1:nsoil) :: rhsttin + real, dimension(1:nsoil) :: ciin + real :: stot + real :: epore + real :: wminus +! ---------------------------------------------------------------------- + wplus = 0.0 + + do k = 1,nsoil + rhstt (k) = rhstt(k) * dt + ai (k) = ai(k) * dt + bi (k) = 1. + bi(k) * dt + ci (k) = ci(k) * dt + end do + +! copy values for input variables before calling rosr12 + + do k = 1,nsoil + rhsttin(k) = rhstt(k) + ciin(k) = ci(k) + end do + +! call rosr12 to solve the tri-diagonal matrix + + call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0) + + do k = 1,nsoil + sh2o(k) = sh2o(k) + ci(k) + enddo + +! excessive water above saturation in a layer is moved to +! its unsaturated layer like in a bucket + +!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table + if(opt_run == 5) then + +!update smcwtd + + if(zwt < zsoil(nsoil)-dzsnso(nsoil))then +!accumulate qdrain to update deep water table and soil moisture later + deeprech = deeprech + dt * qdrain + else + smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil) + wplus = max((smcwtd-parameters%smcmax), 0.0) * dzsnso(nsoil) + wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil) + + smcwtd = max( min(smcwtd,parameters%smcmax) , 1.e-4) + sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil) + +!reduce fluxes at the bottom boundaries accordingly + qdrain = qdrain - wplus/dt + deeprech = deeprech - wminus + endif + + endif + + do k = nsoil,2,-1 + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1) + end do + + epore = max ( 1.e-4 , ( parameters%smcmax - sice(1) ) ) + wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1) + sh2o(1) = min(epore,sh2o(1)) + + end subroutine sstep + +!== begin wdfcnd1 ================================================================================== + + subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: fcr + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + wdf = wdf * (1.0 - fcr) + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + wcnd = wcnd * (1.0 - fcr) + + end subroutine wdfcnd1 + +!== begin wdfcnd2 ================================================================================== + + subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: sice + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + + if (sice > 0.0) then + vkwgt = 1./ (1. + (500.* sice)**3.) + wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat*(0.2/parameters%smcmax)**expon + end if + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + + end subroutine wdfcnd2 + +!== begin groundwater ============================================================================== + + subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !timestep [sec] + real, intent(in) :: fcrmax!maximum fcr (-) + real, dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + +! input and output + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ saturated soil [mm] +! output + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + +! local + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + integer :: iz !do-loop index + integer :: iwt !layer index above water table layer + real, dimension( 1:nsoil) :: dzmm !layer thickness [mm] + real, dimension( 1:nsoil) :: znode !node depth [m] + real, dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm] + real, dimension( 1:nsoil) :: epore !effective porosity [-] + real, dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s] + real, dimension( 1:nsoil) :: smc !total soil water content [m3/m3] + real(kind=8) :: s_node!degree of saturation of iwt layer + real :: dzsum !cumulative depth above water table [m] + real :: smpfz !matric potential (frozen effects) [mm] + real :: ka !aquifer hydraulic conductivity [mm/s] + real :: wh_zwt!water head at water table [mm] + real :: wh !water head at layer above zwt [mm] + real :: ws !water used to fill air pore [mm] + real :: wtsub !sum of hk*dzmm + real :: watmin!minimum soil vol soil moisture [m3/m3] + real :: xs !excessive water above saturation [mm] + real, parameter :: rous = 0.2 !specific yield [-] + real, parameter :: cmic = 0.20 !microprore content (0.0-1.0) + !0.0-close to free drainage +! ------------------------------------------------------------- + qdis = 0.0 + qin = 0.0 + +! derive layer-bottom depth in [mm] +!kwm: derive layer thickness in mm + + dzmm(1) = -zsoil(1)*1.e3 + do iz = 2, nsoil + dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz)) + enddo + +! derive node (middle) depth in [m] +!kwm: positive number, depth below ground surface in m + znode(1) = -zsoil(1) / 2. + do iz = 2, nsoil + znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz)) + enddo + +! convert volumetric soil moisture "sh2o" to mass + + do iz = 1, nsoil + smc(iz) = sh2o(iz) + sice(iz) + mliq(iz) = sh2o(iz) * dzmm(iz) + epore(iz) = max(0.01,parameters%smcmax - sice(iz)) + hk(iz) = 1.e3*wcnd(iz) + enddo + +! the layer index of the first unsaturated layer, +! i.e., the layer right above the water table + + iwt = nsoil + do iz = 2,nsoil + if(zwt .le. -zsoil(iz) ) then + iwt = iz-1 + exit + end if + enddo + +! groundwater discharge [mm/s] + + fff = 6.0 + rsbmx = 5.0 + + qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) + +! matric potential at the layer above the water table + + s_node = min(1.0,smc(iwt)/parameters%smcmax ) + s_node = max(s_node,real(0.01,kind=8)) + smpfz = -parameters%psisat*1000.*s_node**(-parameters%bexp) ! m --> mm + smpfz = max(-120000.0,cmic*smpfz) + +! recharge rate qin to groundwater + + ka = hk(iwt) + + wh_zwt = - zwt * 1.e3 !(mm) + wh = smpfz - znode(iwt)*1.e3 !(mm) + qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3) + qin = max(-10.0/dt,min(10./dt,qin)) + +! water storage in the aquifer + saturated soil + + wt = wt + (qin - qdis) * dt !(mm) + + if(iwt.eq.nsoil) then + wa = wa + (qin - qdis) * dt !(mm) + wt = wa + zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m) + mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm] + + mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.)) + wa = min(wa, 5000.) + else + + if (iwt.eq.nsoil-1) then + zwt = -zsoil(nsoil) & + - (wt-rous*1000*25.) / (epore(nsoil))/1000. + else + ws = 0. ! water used to fill soil air pores + do iz = iwt+2,nsoil + ws = ws + epore(iz) * dzmm(iz) + enddo + zwt = -zsoil(iwt+1) & + - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000. + endif + + wtsub = 0. + do iz = 1, nsoil + wtsub = wtsub + hk(iz)*dzmm(iz) + end do + + do iz = 1, nsoil ! removing subsurface runoff + mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub + end do + end if + + zwt = max(1.5,zwt) + +! +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. +! + watmin = 0.01 + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + wa = wa - xs + wt = wt - xs + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / dzmm(iz) + end do + + end subroutine groundwater + +!== begin shallowwatertable ======================================================================== + + subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in + dzsnso ,smceq ,iloc ,jloc , & !in + smc ,wtd ,smcwtd ,rech, qdrain ) !inout +! ---------------------------------------------------------------------- +!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, +!according to the miguez-macho&fan scheme +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: iloc,jloc + real, intent(in) :: dt + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + +! input and output + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: wtd !the depth to water table [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real, intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up + real, intent(inout) :: qdrain + +! local + integer :: iz !do-loop index + integer :: iwtd !layer index above water table layer + integer :: kwtd !layer index where the water table layer is + real :: wtdold + real :: dzup + real :: smceqdeep + real, dimension( 0:nsoil) :: zsoil0 +! ------------------------------------------------------------- + + +zsoil0(1:nsoil) = zsoil(1:nsoil) +zsoil0(0) = 0. + +!find the layer where the water table is + do iz=nsoil,1,-1 + if(wtd + 1.e-6 < zsoil0(iz)) exit + enddo + iwtd=iz + + + kwtd=iwtd+1 !layer where the water table is + if(kwtd.le.nsoil)then !wtd in the resolved layers + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + + if(smc(kwtd).eq.parameters%smcmax)then !wtd went to the layer above + wtd=zsoil0(iwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + iwtd=iwtd-1 + kwtd=kwtd-1 + if(kwtd.ge.1)then + if(smc(kwtd).gt.smceq(kwtd))then + wtdold=wtd + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=rech-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + endif + else !wtd stays in the layer + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + + else !wtd has gone down to the layer below + wtd=zsoil0(kwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + kwtd=kwtd+1 + iwtd=iwtd+1 +!wtd crossed to the layer below. now adjust it there + if(kwtd.le.nsoil)then + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ) , zsoil0(iwtd) ) + else + wtd=zsoil0(kwtd) + endif + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceq(kwtd)) + + else + wtdold=wtd +!restore smoi to equilibrium value with water from the ficticious layer below +! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil)) +! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt +! smc(nsoil)=smceq(nsoil) +!adjust wtd in the ficticious layer below + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceqdeep) + endif + + endif + elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then +!if wtd was already below the bottom of the resolved soil crust + wtdold=wtd + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + if(smcwtd.gt.smceqdeep)then + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = -(wtdold-wtd) * (parameters%smcmax-smceqdeep) + else + rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax-smceqdeep) + wtdold=zsoil0(nsoil)-dzsnso(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax-smceqdeep) + wtd=wtdold-dzup + rech = rech - (parameters%smcmax-smceqdeep)*dzup + smcwtd=smceqdeep + endif + + + endif + +if(iwtd.lt.nsoil)smcwtd=parameters%smcmax + +end subroutine shallowwatertable + +! ================================================================================================== +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + +!== begin carbon =================================================================================== + + subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,xlai ,xsai ) !out +! ------------------------------------------------------------------------------------------ + implicit none +! ------------------------------------------------------------------------------------------ +! inputs (carbon) + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real , intent(in) :: tv !vegetation temperature (k) + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: btran !soil water transpiration factor (0 to 1) + real , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+] + real , intent(in) :: apar !par by canopy (w/m2) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real , intent(in) :: fveg !vegetation greenness fraction + real , intent(in) :: troot !root-zone averaged temperature (k) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + +! input & output (carbon) + + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2] + +! outputs: (carbon) + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real , intent(out) :: nee !net ecosystem exchange [g/m2/s co2] + real , intent(out) :: autors !net ecosystem respiration [g/m2/s c] + real , intent(out) :: heters !organic respiration [g/m2/s c] + real , intent(out) :: totsc !total soil carbon [g/m2 c] + real , intent(out) :: totlb !total living carbon ([g/m2 c] + real , intent(out) :: xlai !leaf area index [-] + real , intent(out) :: xsai !stem area index [-] +! real , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] + +! local variables + + integer :: j !do-loop index + real :: wroot !root zone soil water [-] + real :: wstres !water stress coeficient [-] (1. for wilting ) + real :: lapm !leaf area per unit mass [m2/g] +! ------------------------------------------------------------------------------------------ + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then + xlai = 0. + xsai = 0. + gpp = 0. + npp = 0. + nee = 0. + autors = 0. + heters = 0. + totsc = 0. + totlb = 0. + lfmass = 0. + rtmass = 0. + stmass = 0. + wood = 0. + stblcp = 0. + fastcp = 0. + + return + end if + + lapm = parameters%sla / 1000. ! m2/kg -> m2/g + +! water stress + + wstres = 1.- btran + + wroot = 0. + do j=1,parameters%nroot + wroot = wroot + smc(j)/parameters%smcmax * dzsnso(j) / (-zsoil(parameters%nroot)) + enddo + + call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out + +! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv) +! call ch4 + + end subroutine carbon + +!== begin co2flux ================================================================================== + + subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out +! ----------------------------------------------------------------------------------------- +! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004 +! ----------------------------------------------------------------------------------------- + implicit none +! ----------------------------------------------------------------------------------------- + +! input + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: dt !time step (s) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s) + real , intent(in) :: troot !root-zone averaged temperature (k) + real , intent(in) :: tv !leaf temperature (k) + real , intent(in) :: wroot !root zone soil water + real , intent(in) :: wstres !soil water stress + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: lapm !leaf area per unit mass [m2/g] + real , intent(in) :: fveg !vegetation greenness fraction + +! input and output + + real , intent(inout) :: xlai !leaf area index from leaf carbon [-] + real , intent(inout) :: xsai !stem area index from leaf carbon [-] + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: fastcp !short lived carbon [g/m2] + real , intent(inout) :: stblcp !stable carbon pool [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + +! output + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s] + real , intent(out) :: npp !net primary productivity [g/m2] + real , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp) + real , intent(out) :: autors !net ecosystem resp. (maintance and growth) + real , intent(out) :: heters !organic respiration + real , intent(out) :: totsc !total soil carbon (g/m2) + real , intent(out) :: totlb !total living carbon (g/m2) + +! local + + real :: cflux !carbon flux to atmosphere [g/m2/s] + real :: lfmsmn !minimum leaf mass [g/m2] + real :: rswood !wood respiration [g/m2] + real :: rsleaf !leaf maintenance respiration per timestep [g/m2] + real :: rsroot !fine root respiration per time step [g/m2] + real :: nppl !leaf net primary productivity [g/m2/s] + real :: nppr !root net primary productivity [g/m2/s] + real :: nppw !wood net primary productivity [g/m2/s] + real :: npps !wood net primary productivity [g/m2/s] + real :: dielf !death of leaf mass per time step [g/m2] + + real :: addnpplf !leaf assimil after resp. losses removed [g/m2] + real :: addnppst !stem assimil after resp. losses removed [g/m2] + real :: carbfx !carbon assimilated per model step [g/m2] + real :: grleaf !growth respiration rate for leaf [g/m2/s] + real :: grroot !growth respiration rate for root [g/m2/s] + real :: grwood !growth respiration rate for wood [g/m2/s] + real :: grstem !growth respiration rate for stem [g/m2/s] + real :: leafpt !fraction of carbon allocated to leaves [-] + real :: lfdel !maximum leaf mass available to change [g/m2/s] + real :: lftovr !stem turnover per time step [g/m2] + real :: sttovr !stem turnover per time step [g/m2] + real :: wdtovr !wood turnover per time step [g/m2] + real :: rssoil !soil respiration per time step [g/m2] + real :: rttovr !root carbon loss per time step by turnover [g/m2] + real :: stablc !decay rate of fast carbon to slow carbon [g/m2/s] + real :: woodf !calculated wood to root ratio [-] + real :: nonlef !fraction of carbon to root and wood [-] + real :: rootpt !fraction of carbon flux to roots [-] + real :: woodpt !fraction of carbon flux to wood [-] + real :: stempt !fraction of carbon flux to stem [-] + real :: resp !leaf respiration [umol/m2/s] + real :: rsstem !stem respiration [g/m2/s] + + real :: fsw !soil water factor for microbial respiration + real :: fst !soil temperature factor for microbial respiration + real :: fnf !foliage nitrogen adjustemt to respiration (<= 1) + real :: tf !temperature factor + real :: rf !respiration reduction factor (<= 1) + real :: stdel + real :: stmsmn + real :: sapm !stem area per unit mass (m2/g) + real :: diest +! -------------------------- constants ------------------------------- + real :: bf !parameter for present wood allocation [-] + real :: rswoodc !wood respiration coeficient [1/s] + real :: stovrc !stem turnover coefficient [1/s] + real :: rsdryc !degree of drying that reduces soil respiration [-] + real :: rtovrc !root turnover coefficient [1/s] + real :: wstrc !water stress coeficient [-] + real :: laimin !minimum leaf area index [m2/m2] + real :: xsamin !minimum leaf area index [m2/m2] + real :: sc + real :: sd + real :: vegfrac + +! respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- + +! constants + rtovrc = 2.0e-8 !original was 2.0e-8 + rsdryc = 40.0 !original was 40.0 + rswoodc = 3.0e-10 ! + bf = 0.90 !original was 0.90 ! carbon to roots + wstrc = 100.0 + laimin = 0.05 + xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring + + sapm = 3.*0.001 ! m2/kg -->m2/g + lfmsmn = laimin/lapm + stmsmn = xsamin/sapm +! --------------------------------------------------------------------------------- + +! respiration + + if(igs .eq. 0.) then + rf = 0.5 + else + rf = 1.0 + endif + + fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 ) + tf = parameters%arm**( (tv-298.16)/10. ) + resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s + rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s + + rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rswood = rswoodc * r(tv) * wood*parameters%wdpool + +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon; + + carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon + +! fraction of carbon into leaf versus nonleaf + + leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai) + if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai) + + nonlef = 1.0 - leafpt + stempt = xlai/10.0*leafpt + leafpt = leafpt - stempt + +! fraction of carbon into wood versus root + + if(wood.gt.0) then + woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool + else + woodf = 0. + endif + + rootpt = nonlef*(1.-woodf) + woodpt = nonlef*woodf + +! leaf and root turnover per time step + + lftovr = parameters%ltovrc*5.e-7*lfmass + sttovr = parameters%ltovrc*5.e-7*stmass + rttovr = rtovrc*rtmass + wdtovr = 9.5e-10*wood + +! seasonal leaf die rate dependent on temp and water stress +! water stress is set to 1 at permanent wilting point + + sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.) + sd = exp((wstres-1.)*wstrc) + dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + +! calculate growth respiration for leaf, rtmass and wood + + grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf)) + grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem)) + grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot)) + grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood)) + +! impose lower t limit for photosynthesis + + addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf) + addnppst = max(0.,stempt*carbfx - grstem-rsstem) +! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil +! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil + if(tv.lt.parameters%tmin) addnpplf =0. + if(tv.lt.parameters%tmin) addnppst =0. + +! update leaf, root, and wood carbon +! avoid reducing leaf mass below its minimum value but conserve mass + + lfdel = (lfmass - lfmsmn)/dt + stdel = (stmass - stmsmn)/dt + dielf = min(dielf,lfdel+addnpplf-lftovr) + diest = min(diest,stdel+addnppst-sttovr) + +! net primary productivities + + nppl = max(addnpplf,-lfdel) + npps = max(addnppst,-stdel) + nppr = rootpt*carbfx - rsroot - grroot + nppw = woodpt*carbfx - rswood - grwood + +! masses of plant components + + lfmass = lfmass + (nppl-lftovr-dielf)*dt + stmass = stmass + (npps-sttovr-diest)*dt ! g/m2 + rtmass = rtmass + (nppr-rttovr) *dt + + if(rtmass.lt.0.0) then + rttovr = nppr + rtmass = 0.0 + endif + wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool + +! soil carbon budgets + + fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7 + + fst = 2.0**( (stc(1)-283.16)/10. ) + fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot) + rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6 + + stablc = 0.1*rssoil + fastcp = fastcp - (rssoil + stablc)*dt + stblcp = stblcp + stablc*dt + +! total carbon flux + + cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7 + + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s + +! for outputs + + gpp = carbfx !g/m2/s c + npp = nppl + nppw + nppr +npps !g/m2/s c + autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7 + grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7 + heters = 0.9*rssoil !g/m2/s c + nee = (autors + heters - gpp)*44./12. !g/m2/s co2 + totsc = fastcp + stblcp !g/m2 c + totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7 + +! leaf area index and stem area index + + xlai = max(lfmass*lapm,laimin) + xsai = max(stmass*sapm,xsamin) + + end subroutine co2flux + +!== begin bvocflux ================================================================================= + +! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv ) +! +! ------------------------------------------------------------------------------------------ +! implicit none +! ------------------------------------------------------------------------------------------ +! +! ------------------------ code history --------------------------- +! source file: bvoc +! purpose: bvoc emissions +! description: +! volatile organic compound emission +! this code simulates volatile organic compound emissions +! following the algorithm presented in guenther, a., 1999: modeling +! biogenic volatile organic compound emissions to the atmosphere. in +! reactive hydrocarbons in the atmosphere, ch. 3 +! this model relies on the assumption that 90% of isoprene and monoterpene +! emissions originate from canopy foliage: +! e = epsilon * gamma * density * delta +! the factor delta (longterm activity factor) applies to isoprene emission +! from deciduous plants only. we neglect this factor at the present time. +! this factor is discussed in guenther (1997). +! subroutine written to operate at the patch level. +! in final implementation, remember: +! 1. may wish to call this routine only as freq. as rad. calculations +! 2. may wish to place epsilon values directly in pft-physiology file +! ------------------------ input/output variables ----------------- +! input +! integer ,intent(in) :: vegtyp !vegetation type +! real ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,intent(in) :: tv !vegetation canopy temperature (k) +! +! output +! real ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] +! +! local variables +! +! real, parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [k] +! real, parameter :: tstd = 303.0 ! std temperature [k] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [k-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! +! epsilon : +! +! do ivoc = 1, 5 +! epsilon(ivoc) = parameters%eps(vegtyp,ivoc) +! end do +! +! gamma : activity factor. units [dimensionless] +! +! reciprod = 1. / (r * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! +! foliage density +! +! transform vegfrac to lai +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (parameters%slarea(vegtyp) * 0.5) +! +! calculate the voc flux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux +! ================================================================================================== +! ********************************* end of carbon subroutines ***************************** +! ================================================================================================== + +!== begin noahmp_options =========================================================================== + + subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options + + +end module module_sf_noahmplsm + diff --git a/physics/module_wrf_utl.f90 b/physics/module_wrf_utl.f90 new file mode 100755 index 000000000..29f8bb9e1 --- /dev/null +++ b/physics/module_wrf_utl.f90 @@ -0,0 +1,50 @@ +module module_wrf_utl + implicit none +contains + +subroutine wrf_error_fatal(string) + implicit none + character(len=*), intent(in) :: string + print*, string + stop +end subroutine wrf_error_fatal + +subroutine wrf_message(msg) + implicit none + character(len=*), intent(in) :: msg + write(*,'(A)') msg +end subroutine wrf_message + +logical function wrf_dm_on_monitor() result (return_value) + implicit none + return_value = .TRUE. +end function wrf_dm_on_monitor + +subroutine wrf_dm_bcast_real(rval, ival) + implicit none + real, intent(in) :: rval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_real + +subroutine wrf_dm_bcast_integer(ival1, ival2) + implicit none + real, intent(in) :: ival1 + integer, intent(in) :: ival2 +end subroutine wrf_dm_bcast_integer + +subroutine wrf_dm_bcast_string(sval, ival) + implicit none + character(len=*), intent(in) :: sval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_string + +subroutine wrf_debug( level , str ) + implicit none + character*(*) str + integer , intent (in) :: level + call wrf_message( str ) + return +end subroutine wrf_debug + +end module module_wrf_utl + diff --git a/physics/noahmp_tables.f90 b/physics/noahmp_tables.f90 new file mode 100755 index 000000000..cbad19b4b --- /dev/null +++ b/physics/noahmp_tables.f90 @@ -0,0 +1,955 @@ +module noahmp_tables + + implicit none + + integer :: i + integer, private, parameter :: mvt = 30 ! use 30 instead of 27 + integer, private, parameter :: mband = 2 + integer, private, parameter :: msc = 8 + integer, private, parameter :: max_soiltyp = 30 + integer, private, parameter :: slcats = 30 + real :: slope_table(9) !slope factor for soil drainage + +! crops + + integer, private, parameter :: ncrop = 5 + integer, private, parameter :: nstage = 8 + + +! mptable.tbl vegetation parameters + + integer :: isurban_table = 13 + integer :: iswater_table = 17 + integer :: isbarren_table = 16 + integer :: isice_table = 15 + integer :: eblforest_table = 2 + +! + real :: ch2op_table(mvt) !maximum intercepted h2o per unit lai+sai (mm) + + data ( ch2op_table(i),i=1,mvt) / 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, & + & 0.1, 0.1, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: dleaf_table(mvt) !characteristic leaf dimension (m) + data ( dleaf_table(i),i=1,mvt) / 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, & + & 0.04, 0.04, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: z0mvt_table(mvt) !momentum roughness length (m) + data ( z0mvt_table(i),i=1,mvt) / 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, & + & 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, & + & 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, & + & 0.20, 0.03, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + + real :: hvt_table(mvt) !top of canopy (m) + data ( hvt_table(i),i=1,mvt) / 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, & + & 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, & + & 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, & + & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: hvb_table(mvt) !bottom of canopy (m) + data ( hvb_table(i),i=1,mvt) / 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, & + & 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, & + & 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, & + & 0.20, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: den_table(mvt) !tree density (no. of trunks per m2) + data ( den_table (i),i=1,mvt) / 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, & + & 10.0, 10.0, 0.02, 100., 5.05, 25.0, & + & 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, & + & 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / +! + real :: rc_table(mvt) !tree crown radius (m) + + data ( rc_table (i),i=1,mvt) / 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, & + & 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, & + & 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, & + & 0.30, 0.30, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: mfsno_table(mvt) !snowmelt curve parameter () + data ( mfsno_table(i),i=1,mvt) / 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, & + & 2.50, 2.50, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + + real :: saim_table(mvt,12) !monthly stem area index, one-sided + + data (saim_table (i,1),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + +! &_______________________________________________________________________& + + data (saim_table (i,2),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,3),i=1,mvt) / 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,4),i=1,mvt) / 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,5),i=1,mvt) / 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,6),i=1,mvt) / 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, & + & 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, & + & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,7),i=1,mvt) / 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, & + & 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, & + & 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, & + & 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,8),i=1,mvt) / 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, & + & 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, & + & 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,9),i=1,mvt) / 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, & + & 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, & + & 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,10),i=1,mvt) / 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, & + & 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, & + & 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (saim_table (i,11),i=1,mvt) / 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, & + & 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, & + & 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (saim_table (i,12),i=1,mvt) / 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, & + & 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, & + & 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +!! lai + real :: laim_table(mvt,12) !monthly leaf area index, one-sided + + data (laim_table (i,1),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & + & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,2),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,3),i=1,mvt) / 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, & + & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,4),i=1,mvt) / 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, & + & 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, & + & 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, & + & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,5),i=1,mvt) / 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, & + & 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, & + & 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, & + & 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,6),i=1,mvt) / 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, & + & 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, & + & 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, & + & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,7),i=1,mvt) / 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, & + & 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, & + & 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, & + & 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,8),i=1,mvt) / 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, & + & 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, & + & 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, & + & 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,9),i=1,mvt) / 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, & + & 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, & + & 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, & + & 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,10),i=1,mvt) / 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, & + & 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, & + & 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + data (laim_table (i,11),i=1,mvt) / 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, & + & 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + data (laim_table (i,12),i=1,mvt) / 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, & + & 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, & + & 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, & + & 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: sla_table(mvt) !single-side leaf area per kg [m2/kg] + data ( sla_table (i),i=1,mvt) / 80, 80, 80, 80, 80, 60, & + & 60, 60, 50, 60, 80, 80, & + & 60, 80, 0, 0, 0, 80, & + & 80, 80, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + real :: dilefc_table(mvt) !coeficient for leaf stress death [1/s] + data (dilefc_table (i),i=1,mvt) / 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, & + & 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, & + & 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, & + & 0.40, 0.30, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dilefw_table(mvt) !coeficient for leaf stress death [1/s] + data (dilefw_table(i),i=1,mvt) / 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, & + & 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, & + & 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, & + & 0.20, 0.20, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: fragr_table(mvt) !fraction of growth respiration !original was 0.3 + data ( fragr_table(i),i=1,mvt) / 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, & + & 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, & + & 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, & + & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: ltovrc_table(mvt) !leaf turnover [1/s] + data ( ltovrc_table(i),i=1,mvt) / 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, & + & 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, & + & 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, & + & 1.4, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +! + real :: c3psn_table(mvt) !photosynthetic pathway: 0. = c4, 1. = c3 + data ( c3psn_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: kc25_table(mvt) !co2 michaelis-menten constant at 25c (pa) + data ( kc25_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, & + & 30.0, 30.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: akc_table(mvt) !q10 for kc25 + data ( akc_table (i),i=1,mvt) / 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, & + & 2.1, 2.1, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + real :: ko25_table(mvt) !o2 michaelis-menten constant at 25c (pa) + data ( ko25_table (i),i=1,mvt) / 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, 3.e4, & + & 3.e4, 3.e4, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: ako_table(mvt) !q10 for ko25 + data ( ako_table (i),i=1,mvt) / 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, & + & 1.2, 1.2, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: vcmx25_table(mvt) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + data ( vcmx25_table(i),i=1,mvt) / 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, & + & 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, & + & 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, & + & 50.0, 50.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: avcmx_table(mvt) !q10 for vcmx25 + data ( avcmx_table (i),i=1,mvt) / 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, & + & 2.4, 2.4, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + + real :: bp_table(mvt) !minimum leaf conductance (umol/m**2/s) + data ( bp_table (i),i=1,mvt) / 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & + & 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, 2.e3, & + & 1.e15, 2.e3,1.e15, 2.e3,1.e15, 2.e3, & + & 2.e3, 2.e3, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: mp_table(mvt) !slope of conductance-to-photosynthesis relationship + data ( mp_table (i),i=1,mvt) / 6., 9., 6., 9., 9., 9., & + & 9., 9., 9., 9., 9., 9., & + & 9., 9., 9., 9., 9., 9., & + & 9., 9., 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: qe25_table(mvt) !quantum efficiency at 25c (umol co2 / umo photon) + data ( qe25_table (i),i=1,mvt) / 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & + & 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, & + & 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, & + & 0.06, 0.06, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: aqe_table(mvt) !q10 for qe25 + data ( aqe_table (i),i=1,mvt) / 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, & + & 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: rmf25_table(mvt) !leaf maintenance respiration at 25c (umol co2/m**2/s) + data ( rmf25_table (i),i=1,mvt) / 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, & + & 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, & + & 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, & + & 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rms25_table(mvt) !stem maintenance respiration at 25c (umol co2/kg bio/s) + data ( rms25_table (i),i=1,mvt) / 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, & + & 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, & + & 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, & + & 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rmr25_table(mvt) !root maintenance respiration at 25c (umol co2/kg bio/s) + data ( rmr25_table (i),i=1,mvt) / 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, & + & 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, & + & 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: arm_table(mvt) !q10 for maintenance respiration + data ( arm_table (i),i=1,mvt) / 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, & + & 2.0, 2.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: folnmx_table(mvt) !foliage nitrogen concentration when f(n)=1 (%) + data (folnmx_table (i),i=1,mvt) / 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & + & 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, & + & 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, & + & 1.5, 1.5, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: tmin_table(mvt) !minimum temperature for photosynthesis (k) + data ( tmin_table (i),i=1,mvt) / 265, 273, 268, 273, 268, 273, & + & 273, 273, 273, 273, 268, 273, & + & 0, 273, 0, 0, 0, 268, & + & 268, 268, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + +! + real :: xl_table(mvt) !leaf/stem orientation index + data ( xl_table (i),i=1,mvt) / 0.010,0.010,0.010,0.250,0.250,0.010, & + & 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, & + & 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, & + & 0.250, 0.250, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / +! + real :: rhol_table(mvt,mband) !leaf reflectance: 1=vis, 2=nir + + data ( rhol_table (i,1),i=1,mvt) / 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, & + & 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, & + & 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, & + & 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! &_______________________________________________________________________& + + data ( rhol_table (i,2),i=1,mvt) / 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, & + & 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, & + & 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, & + & 0.45, 0.45, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rhos_table(mvt,mband) !stem reflectance: 1=vis, 2=nir + + data ( rhos_table (i,1),i=1,mvt) / 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, & + & 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, & + & 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, & + & 0.16,0.16, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + data ( rhos_table (i,2),i=1,mvt) / 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, & + & 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, & + & 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, & + & 0.39, 0.39, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! &_______________________________________________________________________& + + real :: taul_table(mvt,mband) !leaf transmittance: 1=vis, 2=nir +! + data ( taul_table (i,1),i=1,mvt) / 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, & + & 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, & + & 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, & + & 0.05, 0.05,0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + data ( taul_table (i,2),i=1,mvt) / 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, & + & 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, & + & 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, & + & 0.25, 0.25, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: taus_table(mvt,mband) !stem transmittance: 1=vis, 2=nir + data(taus_table (i,1),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & + & 0.001, 0.001, 0.001, 0.220, 0.1105,0.220, & + & 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / + + + data(taus_table (i,2),i=1,mvt) / 0.001,0.001,0.001,0.001,0.001, 0.001, & + & 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, & + & 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000, & + & 0.001, 0.001, 0.000, 0.000, 0.000, 0.000 / + + + real :: mrp_table(mvt) !microbial respiration parameter (umol co2 /kg c/ s) + data ( mrp_table (i),i=1,mvt) / 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, & + & 0.19, 0.19, 0.40, 0.17,0.285, 0.23, & + & 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, & + & 0.20, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +! + real :: cwpvt_table(mvt) !empirical canopy wind parameter + data ( cwpvt_table (i),i=1,mvt) / 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.18, 0.18, 0.18, 0.18, & + & 0.18, 0.18, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: wrrat_table(mvt) !wood to non-wood ratio + data ( wrrat_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, & + & 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, & + & 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: wdpool_table(mvt) !wood pool (switch 1 or 0) depending on woody or not [-] + data ( wdpool_table(i),i=1,mvt) / 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, & + & 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, & + & 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: tdlef_table(mvt) !characteristic t for leaf freezing [k] + data ( tdlef_table (i),i=1,mvt) / 278, 278, 268, 278, 268, 278, & + & 278, 278, 278, 278, 268, 278, & + & 278, 278, 0, 0, 0, 268, & + & 268, 268, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + + real :: nroot_table(mvt) !number of soil layers with root present + data ( nroot_table (i),i=1,mvt) / 4, 4, 4, 4, 4, 3, & + & 3, 3, 3, 3, 2, 3, & + & 1, 3, 1, 1, 0, 3, & + & 3, 2, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0 / + + real :: rgl_table(mvt) !parameter used in radiation stress function + data ( rgl_table (i),i=1,mvt) / 30.0, 30.0, 30.0, 30.0, 30.0, 100.0,& + & 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, & + & 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, & + & 100.0, 100.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rs_table(mvt) !minimum stomatal resistance [s m-1] + data ( rs_table (i),i=1,mvt) / 125.0, 150.0,150.0,100.0,125.0,300.0,& + & 170.0,300.0, 70.0, 40.0, 70.0, 40.0, & + & 200.0, 40.0, 999.0,999.0,100.0,150.0, & + & 150.0, 200.0,0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: hs_table(mvt) !parameter used in vapor pressure deficit function + data ( hs_table (i),i=1,mvt) / 47.35,41.69,47.35,54.53,51.93,42.00, & + & 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, & + & 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, & + & 42.00, 42.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + + real :: topt_table(mvt) !optimum transpiration air temperature [k] + data ( topt_table (i),i=1,mvt) / 298.0,298.0,298.0,298.0,298.0,298.0, & + & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & + & 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, & + & 298.0, 298.0, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: rsmax_table(mvt) !maximal stomatal resistance [s m-1] + data ( rsmax_table (i),i=1,mvt) / 5000., 5000.,5000.,5000.,5000.,5000.,& + & 5000., 5000., 5000., 5000., 5000., 5000., & + & 5000., 5000., 5000., 5000., 5000., 5000., & + & 5000., 5000., 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +!!!!!!!!!!!!!! Wield not defined but read !!!!!!!!!!!!!!!!1 + + real :: slarea_table(mvt) + + data (slarea_table (i),i=1,mvt) / 0.0090,0.0200,0.0200,0.0258,0.0223, & + & 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, & + & 0.0295, 0.0200, 0.0228, 0.0223, 0.02, & + & 0.02, 0.0422, 0.02, 0.02, 0.02, & + & 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0 / + +! &_______________________________________________________________________& + + real :: esp1_table(mvt) + + data (esp1_table (i),i=1,mvt) / 0.46, 0.00, 0.00,46.86,30.98, 21.62, & + & 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, & + & 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, & + & 0.0, 0.0,0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + real :: esp2_table(mvt) + + data (esp2_table (i),i=1,mvt) / 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, & + & 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, & + & 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + + real :: esp3_table(mvt) + + data (esp3_table (i),i=1,mvt) / 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, & + & 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, & + & 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + + +! &_______________________________________________________________________& + + real :: esp4_table(mvt) + + data (esp4_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + real :: esp5_table(mvt) + + data (esp5_table (i),i=1,mvt) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 / + +!!!!!!!!!!!!!!!!!!! what are the tables used for !!!!!!!!!!!!!! + +! soilparm.tbl parameters + + real :: bexp_table(max_soiltyp) + + data (bexp_table(i), i=1,slcats) /2.79, 4.26, 4.74, 5.33, 5.33, 5.25,& + & 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, & + & 5.25, 0.0, 2.79, 4.26, 11.55, 2.79, & + & 2.79, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: smcdry_table(max_soiltyp) + data (smcdry_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.084,& + & 0.066, 0.067, 0.120, 0.103, 0.100, 0.126, 0.138, & + & 0.066, 0.0, 0.006, 0.028, 0.030, 0.006, & + & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: f1_table(max_soiltyp) + + data (f1_table(i), i=1,slcats) /-0.472, -1.044, -0.569, 0.162, 0.162, & + & -0.327, -1.491, -1.118, -1.297, -3.209, -1.916, -2.138, & + & -0.327, 0.000, -1.111, -1.044, -10.472, -0.472, & + & -0.472, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: smcmax_table(max_soiltyp) + + data (smcmax_table(i), i=1,slcats) /0.339, 0.421, 0.434, 0.476, 0.476,& + & 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & + & 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & + & 0.339, 0.339, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: smcref_table(max_soiltyp) + + data (smcref_table(i), i=1,slcats) /0.236, 0.383, 0.383, 0.360, 0.383, & + & 0.329, 0.314, 0.387, 0.382, 0.338, 0.404, 0.412, & + & 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, & + & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: psisat_table(max_soiltyp) + + data (psisat_table(i), i=1,slcats) /0.069, 0.036, 0.141, 0.759, 0.759, & + & 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, & + & 0.355, 0.00, 0.069, 0.036, 0.468, 0.069, & + & 0.069, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dksat_table(max_soiltyp) + + data (dksat_table(i), i=1,slcats) /4.66e-5, 1.41e-5, 5.23e-6, 2.81e-6, & + & 2.81e-6, 3.38e-6, 4.45e-6, 2.03e-6, 2.45e-6,7.22e-6, & + & 1.34e-6, 9.74e-7, 3.38e-6, 0.00, 1.41e-4, & + & 1.41e-5, 9.74e-7, 1.41e-4, 4.66e-5,0.0, & + & 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: dwsat_table(max_soiltyp) + + data (dwsat_table(i), i=1,slcats) /0.608e-6, 0.514e-5, 0.805e-5, & + & 0.239e-4, 0.239e-4,0.143e-4, 0.99e-5, 0.237e-4, 0.113e-4, 0.187e-4, & + & 0.964e-5, 0.112e-4,0.143e-4,0.00, 0.136e-3, 0.514e-5, & + & 0.112e-4, 0.136e-3, 0.608e-6, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00 / + + real :: smcwlt_table(max_soiltyp) + + data (smcwlt_table(i), i=1,slcats) /0.010, 0.028, 0.047, 0.084, 0.084,& + & 0.066, 0.067, 0.120, 0.103, 0.100, 0.126, 0.138, & + & 0.066, 0.00, 0.006, 0.028, 0.03, 0.006, & + & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 / + + real :: quartz_table(max_soiltyp) + + data (quartz_table(i), i=1,slcats) /0.92, 0.82, 0.60, 0.25, 0.10, & + & 0.40, 0.60, 0.10, 0.35, 0.52, 0.10, & + & 0.25, 0.05, 0.60, 0.07, 0.25, 0.60, & + & 0.52, 0.92, 0.00, 0.00, 0.00, 0.00,0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + + +! genparm.tbl parameters + + data (slope_table(i), i=1,9) /0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & + & 0.63, 0.0, 0.0 / + + real :: csoil_table = 2.00e+6 !soil heat capacity [j m-3 k-1] + real :: refdk_table = 2.0e-6 !parameter in the surface runoff parameterization + real :: refkdt_table = 3.0 !parameter in the surface runoff parameterization + real :: frzk_table =0.15 !frozen ground parameter + real :: zbot_table = -8.0 !depth [m] of lower boundary soil temperature + real :: czil_table = 0.075 !parameter used in the calculation of the roughness length for heat + +! mptable.tbl radiation parameters + +! &_______________________________________________________________________& + real :: albsat_table(msc,mband) !saturated soil albedos: 1=vis, 2=nir + data(albsat_table(i,1),i=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ + data(albsat_table(i,2),i=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + + real :: albdry_table(msc,mband) !dry soil albedos: 1=vis, 2=nir + data(albdry_table(i,1),i=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + data(albdry_table(i,2),i=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ + + real :: albice_table(mband) !albedo land ice: 1=vis, 2=nir + data (albice_table(i),i=1,mband) /0.80, 0.55/ + + real :: alblak_table(mband) !albedo frozen lakes: 1=vis, 2=nir + data (alblak_table(i),i=1,mband) /0.60, 0.40/ + + real :: omegas_table(mband) !two-stream parameter omega for snow + data (omegas_table(i),i=1,mband) /0.8, 0.4/ + + real :: betads_table = 0.5 !two-stream parameter betad for snow + real :: betais_table = 0.5 !two-stream parameter betad for snow + + real :: eg_table(2) !emissivity + data eg_table /0.97, 0.98 / + + real :: betads, betais + data betads, betais /0.5, 0.5/ + + +! mptable.tbl global parameters + + real :: co2_table = 395.e-06 !co2 partial pressure + real :: o2_table = 0.209 !o2 partial pressure + real :: timean_table = 10.5 !gridcell mean topgraphic index (global mean) + real :: fsatmx_table = 0.38 !maximum surface saturated fraction (global mean) + real :: z0sno_table = 0.002 !snow surface roughness length (m) (0.002) + real :: ssi_table = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + real :: swemx_table = 1.00 !new snow mass to fully cover old snow (mm) + real :: rsurf_snow_table = 50.0 !surface resistance for snow(s/m) + + +! Noah mp crops +! mptable.tbl crop parameters +! ! NCROP = 5 +! 1: Corn +! 2: Soybean +! 3: Sorghum +! 4: Rice +! 5: Winter wheat + + +! &_______________________________________________________________________& + integer :: pltday_table(ncrop) ! planting date + data (pltday_table(i), i=1,5) /130,111,111,111,111/ + + integer :: hsday_table(ncrop) ! harvest date + data (hsday_table(i),i=1,5) /280,300,300,300,300/ + + real :: plantpop_table(ncrop) ! plant density [per ha] - used? + data (plantpop_table(i),i=1,5) /78.0,78.0,78.0,78.0,78.0/ + + real :: irri_table(ncrop) ! irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + data (irri_table(i),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: gddtbase_table(ncrop) ! base temperature for gdd accumulation [c] + data (gddtbase_table(i),i=1,5) /10.0,10.0,10.0,10.0,10.0/ + + real :: gddtcut_table(ncrop) ! upper temperature for gdd accumulation [c] + data (gddtcut_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ + + real :: gdds1_table(ncrop) ! gdd from seeding to emergence + data (gdds1_table(i),i=1,5) /60.0,50.0,50.0,50.0,50.0/ + + real :: gdds2_table(ncrop) ! gdd from seeding to initial vegetative + data (gdds2_table(i),i=1,5) /675.0,718.0,718.0,718.0,718.0/ + + real :: gdds3_table(ncrop) ! gdd from seeding to post vegetative + data (gdds3_table(i),i=1,5) /1183.0,933.0,933.0,933.0,933.0/ + + real :: gdds4_table(ncrop) ! gdd from seeding to intial reproductive + data (gdds4_table(i),i=1,5) /1253.0,1103.0,1103.0,1103.0,1103.0/ + + real :: gdds5_table(ncrop) ! gdd from seeding to pysical maturity + data (gdds5_table(i),i=1,5) /1605.0,1555.0,1555.0,1555.0,1555.0/ + + integer :: c3c4_table(ncrop) ! photosynthetic pathway: 1. = c3 2. = c4 + data (c3c4_table(i),i=1,5) /2.0,1.0,2.0,2.0,2.0/ + + real :: aref_table(ncrop) ! reference maximum co2 assimulation rate + data (aref_table(i),i=1,5) /7.0,7.0,7.0,7.0,7.0/ + + real :: psnrf_table(ncrop) ! co2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + data (psnrf_table(i),i=1,5) /0.85,0.85,0.85,0.85,0.85/ + + real :: i2par_table(ncrop) ! fraction of incoming solar radiation to photosynthetically active radiation + data (i2par_table(i),i=1,5) / 0.5,0.5,0.5,0.5,0.5/ + + real :: tassim0_table(ncrop) ! minimum temperature for co2 assimulation [c] + data (tassim0_table(i),i=1,5) /8.0,8.0,8.0,8.0,8.0/ + + real :: tassim1_table(ncrop) ! co2 assimulation linearly increasing until temperature reaches t1 [c] + data (tassim1_table(i),i=1,5) /18.0,18.0,18.0,18.0,18.0/ + + real :: tassim2_table(ncrop) ! co2 assmilation rate remain at aref until temperature reaches t2 [c] + data (tassim2_table(i),i=1,5) /30.0,30.0,30.0,30.0,30.0/ + + real :: k_table(ncrop) ! light extinction coefficient + data ( k_table(i),i=1,5) /0.55,0.55,0.55,0.55,0.55/ + + real :: epsi_table(ncrop) ! initial light use efficiency + data (epsi_table(i),i=1,5) /12.5,12.5,12.5,12.5,12.5/ + + real :: q10mr_table(ncrop) ! q10 for maintainance respiration + data (q10mr_table(i),i=1,5) /2.0,2.0,2.0,2.0,2.0/ + + real :: foln_mx_table(ncrop) ! foliage nitrogen concentration when f(n)=1 (%) + data (foln_mx_table(i),i=1,5) /1.5,1.5,1.5,1.5,1.5/ + + real :: lefreez_table(ncrop) ! characteristic t for leaf freezing [k] + data (lefreez_table(i),i=1,5) /268,268,268,268,268/ + + + real :: dile_fc_table(ncrop,nstage) ! coeficient for temperature leaf stress death [1/s] + data (dile_fc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,5),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (dile_fc_table(i,6),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (dile_fc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: dile_fw_table(ncrop,nstage) ! coeficient for water leaf stress death [1/s] + data (dile_fw_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,5),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (dile_fw_table(i,6),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (dile_fw_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (dile_fw_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: fra_gr_table(ncrop) ! fraction of growth respiration + data (fra_gr_table(i),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + + real :: lf_ovrc_table(ncrop,nstage) ! fraction of leaf turnover [1/s] + data (lf_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,5),i=1,5) /0.2,0.48,0.48,0.48,0.48/ + data (lf_ovrc_table(i,6),i=1,5) /0.3,0.48,0.48,0.48,0.48/ + data (lf_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lf_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: st_ovrc_table(ncrop,nstage) ! fraction of stem turnover [1/s] + data (st_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ + data (st_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ + data (st_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (st_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: rt_ovrc_table(ncrop,nstage) ! fraction of root tunrover [1/s] + data (rt_ovrc_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,5),i=1,5) /0.12,0.12,0.12,0.12,0.12/ + data (rt_ovrc_table(i,6),i=1,5) /0.06,0.06,0.06,0.06,0.06/ + data (rt_ovrc_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rt_ovrc_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: lfmr25_table(ncrop) ! leaf maintenance respiration at 25c [umol co2/m**2 /s] + data (lfmr25_table(i),i=1,5) /1.0,1.0,1.0,1.0,1.0/ + + real :: stmr25_table(ncrop) ! stem maintenance respiration at 25c [umol co2/kg bio/s] + data (stmr25_table(i),i=1,5) /0.05,0.1,0.1,0.1,0.1/ + + real :: rtmr25_table(ncrop) ! root maintenance respiration at 25c [umol co2/kg bio/s] + data (rtmr25_table(i),i=1,5) /0.05,0.0,0.0,0.0,0.0/ + + real :: grainmr25_table(ncrop) ! grain maintenance respiration at 25c [umol co2/kg bio/s] + data (grainmr25_table(i),i=1,5) /0.0,0.1,0.1,0.1,0.1/ + + real :: lfpt_table(ncrop,nstage) ! fraction of carbohydrate flux to leaf + data (lfpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,3),i=1,5) /0.4,0.4,0.4,0.4,0.4/ + data (lfpt_table(i,4),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (lfpt_table(i,5),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,6),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (lfpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + + real :: stpt_table(ncrop,nstage) ! fraction of carbohydrate flux to stem + data (stpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,3),i=1,5) /0.2,0.2,0.2,0.2,0.2/ + data (stpt_table(i,4),i=1,5) /0.5,0.5,0.5,0.5,0.5/ + data (stpt_table(i,5),i=1,5) /0.0,0.15,0.15,0.15,0.15/ + data (stpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ + data (stpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (stpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + + real :: rtpt_table(ncrop,nstage) ! fraction of carbohydrate flux to root + data (rtpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,3),i=1,5) /0.34,0.4,0.4,0.4,0.4/ + data (rtpt_table(i,4),i=1,5) /0.3,0.3,0.3,0.3,0.3/ + data (rtpt_table(i,5),i=1,5) /0.05,0.05,0.05,0.05,0.05/ + data (rtpt_table(i,6),i=1,5) /0.0,0.05,0.05,0.05,0.05/ + data (rtpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (rtpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: grainpt_table(ncrop,nstage) ! fraction of carbohydrate flux to grain + data (grainpt_table(i,1),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,2),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,3),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,4),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,5),i=1,5) /0.95,0.8,0.8,0.8,0.8/ + data (grainpt_table(i,6),i=1,5) /1.0,0.9,0.9,0.9,0.9/ + data (grainpt_table(i,7),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + data (grainpt_table(i,8),i=1,5) /0.0,0.0,0.0,0.0,0.0/ + + real :: bio2lai_table(ncrop) ! leaf are per living leaf biomass [m^2/kg] + data (bio2lai_table(i),i=1,5) /0.035,0.015,0.015,0.015,0.015/ + +end module noahmp_tables + diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f new file mode 100755 index 000000000..8d12d8fa4 --- /dev/null +++ b/physics/sfc_noahmp_drv.f @@ -0,0 +1,1142 @@ +!----------------------------------- + subroutine noahmpdrv & +!................................... +! --- inputs: + & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & + & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & prsl1, prslki, zf, dry, ddvel, slopetyp, & + & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & idveg,iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & + & iopt_inf,iopt_rad, iopt_alb, iopt_snf,iopt_tbot,iopt_stc, & + & xlatin,xcoszin, iyrlen, julian, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp, & + +! --- in/outs: + & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & + & canopy, trans, tsurf,zorl, & + +! --- Noah MP specific + + & snowxy, tvxy, tgxy, canicexy,canliqxy, eahxy,tahxy,cmxy, & + & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, & + & zwtxy, waxy, wtxy, tsnoxy,zsnsoxy, snicexy, snliqxy, & + & lfmassxy, rtmassxy,stmassxy, woodxy, stblcpxy, fastcpxy, & + & xlaixy,xsaixy,taussxy,smoiseq,smcwtdxy,deeprechxy,rechxy, & + +! --- outputs: + & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & + & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & + & smcwlt2, smcref2,wet1,t2mmp,q2mp) +! +! + use machine , only : kind_phys +! use date_def, only : idate + use funcphys, only : fpvs + use physcons, only : con_g, con_hvap, con_cp, con_jcal, & + & con_eps, con_epsm1, con_fvirt, con_rd,con_hfus + + use module_sf_noahmplsm + use module_sf_noahmp_glacier + use noahmp_tables, only : isice_table, co2_table, o2_table, & + & isurban_table,smcref_table,smcdry_table, & + & smcmax_table,co2_table,o2_table, & + & saim_table,laim_table + + implicit none + +! --- constant parameters: + + real(kind=kind_phys), parameter :: cpinv = 1.0/con_cp + real(kind=kind_phys), parameter :: hvapi = 1.0/con_hvap + real(kind=kind_phys), parameter :: elocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: rhoh2o = 1000.0 + real(kind=kind_phys), parameter :: convrad = con_jcal*1.e4/60.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 + real(kind=kind_phys), parameter :: a3 = 273.16 + real(kind=kind_phys), parameter :: a4 = 35.86 + real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) +! +! --- +! + + real, parameter :: undefined = -1.e36 + + real :: dz8w = undefined + real :: dx = undefined + real :: qc = undefined + real :: foln = 1.0 ! foliage + integer :: nsoil = 4 ! hardwired to Noah + integer :: nsnow = 3 ! max. snow layers + integer :: ist = 1 ! soil type, 1 soil; 2 lake; 14 is water + integer :: isc = 4 ! middle day soil color: soil 1-9 lightest + + real(kind=kind_phys), save :: zsoil(4),sldpth(4) + data zsoil / -0.1, -0.4, -1.0, -2.0 / + data sldpth /0.1, 0.3, 0.6, 1.0 / +! data dzs /0.1, 0.3, 0.6, 1.0 / + +! +! --- input: +! + + integer, intent(in) :: im, km, itime + + integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & + & ch, prsl1, prslki, ddvel, shdmin, shdmax, & + & snoalb, sfalb, zf, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp + + logical, dimension(im), intent(in) :: dry + + real (kind=kind_phys),dimension(im),intent(in) :: xlatin,xcoszin + + integer, intent(in) :: idveg, iopt_crs,iopt_btr,iopt_run, & + & iopt_sfc,iopt_frz,iopt_inf,iopt_rad, & + & iopt_alb,iopt_snf,iopt_tbot,iopt_stc + + real (kind=kind_phys), intent(in) :: julian + integer, intent(in) :: iyrlen + + + real (kind=kind_phys), intent(in) :: delt + logical, dimension(im), intent(in) :: flag_iter, flag_guess + +! --- 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 + + real (kind=kind_phys), dimension(im), intent(inout) :: snowxy, & + & tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy, & + & cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy, & + & wslakexy,zwtxy,waxy,wtxy,lfmassxy,rtmassxy, & + & stmassxy,woodxy,stblcpxy,fastcpxy,xlaixy, & + & xsaixy,taussxy,smcwtdxy,deeprechxy,rechxy + + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: tsnoxy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snicexy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snliqxy + real (kind=kind_phys),dimension(im,1:4), intent(inout) :: smoiseq + real (kind=kind_phys),dimension(im,-2:4),intent(inout) :: zsnsoxy + + integer, dimension(im) :: jsnowxy + real (kind=kind_phys),dimension(im) :: snodep + real (kind=kind_phys),dimension(im,-2:4) :: tsnsoxy + +! --- output: + + real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & + & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & + & t2mmp,q2mp + +! --- locals: + real (kind=kind_phys), dimension(im) :: rch, rho, & + & q0, qs1, theta1, tv1, wind, weasd_old, snwdph_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old + + real (kind=kind_phys), dimension(km) :: et,stsoil,smsoil, slsoil + + real (kind=kind_phys),dimension(im,km) :: smc_old,stc_old,slc_old + + real (kind=kind_phys), dimension(im) :: snow_old, tv_old,tg_old, & + & canice_old,canliq_old,eah_old,tah_old,fwet_old,sneqvo_old, & + & albold_old,qsnow_old,wslake_old,zwt_old,wa_old,wt_old, & + & lfmass_old,rtmass_old,stmass_old,wood_old,stblcp_old, & + & fastcp_old,xlai_old,xsai_old,tauss_old,smcwtd_old, & + & deeprech_old,rech_old + + real(kind=kind_phys),dimension(im,1:4) :: smoiseq_old + real(kind=kind_phys),dimension(im,-2:0) :: tsno_old + real(kind=kind_phys),dimension(im,-2:0) :: snice_old + real(kind=kind_phys),dimension(im,-2:0) :: snliq_old + real(kind=kind_phys),dimension(im,-2:4) :: zsnso_old + real(kind=kind_phys),dimension(im,-2:4) :: tsnso_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, & + & xlai, zlvl, swdn, tem, psfc,fdown,t2v,tbot + + real (kind=kind_phys) :: pconv,pnonc,pshcv,psnow,pgrpl,phail + real (kind=kind_phys) :: lat,cosz,uu,vv,swe + integer :: isnowx + + real (kind=kind_phys) :: tvx,tgx,canicex,canliqx,eahx, & + & tahx,fwetx,sneqvox,alboldx,qsnowx,wslakex,zwtx, & + & wax,wtx,lfmassx, rtmassx,stmassx, woodx,stblcpx, & + & fastcpx,xlaix,xsaix,taussx,smcwtdx,deeprechx,rechx, & + & qsfc1d + + real (kind=kind_phys), dimension(-2:0) :: tsnox, snicex, snliqx + real (kind=kind_phys), dimension(-2:0) :: ficeold + real (kind=kind_phys), dimension( km ) :: smoiseqx + real (kind=kind_phys), dimension(-2:4) :: zsnsox + real (kind=kind_phys), dimension(-2:4) :: tsnsox + + real (kind=kind_phys) :: z0wrf,fsa,fsr,fira,fsh,fcev,fgev, & + & fctr,ecan,etran,trad,tgb,tgv,t2mv, & + & t2mb,q2v,q2b,runsrf,runsub,apar, & + & psn,sav,sag,fsno,nee,gpp,npp,fveg, & + & qsnbot,ponding,ponding1,ponding2, & + & rssun,rssha,bgap,wgap,chv,chb,emissi, & + & shg,shc,shb,evg,evb,ghv,ghb,irg,irc, & + & irb,tr,evc,chleaf,chuc,chv2,chb2, & + & fpice,pahv,pahg,pahb,pah,co2pp,o2pp,ch2b + + integer :: i, k, ice, stype, vtype ,slope,nroot,couple + logical :: flag(im) + logical :: snowng,frzgra + + type(noahmp_parameters) :: parameters + +! +!===> ... begin here +! + +! --- ... set flag for land points + + do i = 1, im + flag(i) = dry(i) + enddo + +! --- ... save land-related prognostic fields for guess run + + do i = 1, im + if (flag(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) +! +! + snow_old(i) = snowxy(i) + tv_old(i) = tvxy(i) + tg_old(i) = tgxy(i) + canice_old(i) = canicexy(i) + canliq_old(i) = canliqxy(i) + eah_old(i) = eahxy(i) + tah_old(i) = tahxy(i) + fwet_old(i) = fwetxy(i) + sneqvo_old(i) = sneqvoxy(i) + albold_old(i) = alboldxy(i) + qsnow_old(i) = qsnowxy(i) + wslake_old(i) = wslakexy(i) + zwt_old(i) = zwtxy(i) + wa_old(i) = waxy(i) + wt_old(i) = wtxy(i) + lfmass_old(i) = lfmassxy(i) + rtmass_old(i) = rtmassxy(i) + stmass_old(i) = stmassxy(i) + wood_old(i) = woodxy(i) + stblcp_old(i) = stblcpxy(i) + fastcp_old(i) = fastcpxy(i) + xlai_old(i) = xlaixy(i) + xsai_old(i) = xsaixy(i) + tauss_old(i) = taussxy(i) + smcwtd_old(i) = smcwtdxy(i) + rech_old(i) = rechxy(i) + + deeprech_old(i) = deeprechxy(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 + +! + do k = 1, km + smoiseq_old(i,k) = smoiseq(i,k) + enddo + + do k = -2,0 + tsno_old(i,k) = tsnoxy(i,k) + snice_old(i,k) = snicexy(i,k) + snliq_old(i,k) = snliqxy(i,k) + enddo + + do k = -2,4 + zsnso_old (i,k) = zsnsoxy(i,k) + enddo + + endif + enddo + +! +! call to init MP options +! +! &_________________________________________________________________ & + +! --- ... initialization block + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ep(i) = 0.0 + evap (i) = 0.0 + hflx (i) = 0.0 + gflux(i) = 0.0 + drain(i) = 0.0 + canopy(i) = max(canopy(i), 0.0) + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + endif + enddo + +! --- ... initialize variables + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + wind(i) = sqrt( u1(i)*u1(i) + v1(i)*v1(i) ) & + & + max(0.0, min(ddvel(i), 30.0)) + wind(i) = max(wind(i), 1.0) + + q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + + tv1(i) = t1(i) * (1.0 + con_fvirt*q0(i)) + rho(i) = prsl1(i) / (con_rd * tv1(i)) + qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) + qs1(i) = con_eps*qs1(i) / (prsl1(i) + con_epsm1*qs1(i)) + qs1(i) = max(qs1(i), 1.e-8) + q0 (i) = min(qs1(i), q0(i)) + + if (vegtype(i) == isice_table ) then + if (weasd(i) < 0.1) then + weasd(i) = 0.1 + endif + endif + + endif + enddo + +! --- ... noah: prepare variables to run noah lsm +! 1. configuration information (c): +! ------------------------------ +! couple - couple-uncouple flag (=1: coupled, =0: uncoupled) +! ffrozp - fraction for snow-rain (1.=snow, 0.=rain, 0-1 mixed)) +! ice - sea-ice flag (=1: sea-ice, =0: land) +! dt - timestep (sec) (dt should not exceed 3600 secs) = delt +! zlvl - height (m) above ground of atmospheric forcing variables +! nsoil - number of soil layers (at least 2) +! sldpth - the thickness of each soil layer (m) + + do i = 1, im + + if (flag_iter(i) .and. flag(i)) then + + + couple = 1 + + ice = 0 + nsoil = km + snowng = .false. + frzgra = .false. + + +! if (srflag(i) == 1.0) then ! snow phase +! ffrozp = 1.0 +! elseif (srflag(i) == 0.0) then ! rain phase +! ffrozp = 0.0 +! endif +! use srflag directly to allow fractional rain/snow + ffrozp = srflag(i) + + zlvl = zf(i) + +! 2. forcing data (f): +! ----------------- +! lwdn - lw dw radiation flux (w/m2) +! solnet - net sw radiation flux (dn-up) (w/m2) +! sfcprs - pressure at height zlvl above ground (pascals) +! prcp - precip rate (kg m-2 s-1) +! sfctmp - air temperature (k) at height zlvl above ground +! th2 - air potential temperature (k) at height zlvl above ground +! q2 - mixing ratio at height zlvl above ground (kg kg-1) + + lat = xlatin(i) ! in radian + cosz = xcoszin(i) + + 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) + + sfctmp = t1(i) + sfcprs = prsl1(i) + psfc = ps(i) + prcp = rhoh2o * tprcp(i) / delt + + if (prcp > 0.0) then + if (ffrozp > 0.0) then ! rain/snow flag, one condition is enough? + snowng = .true. + qsnowxy(i) = ffrozp * prcp/10.0 !still use rho water? + else + if (sfctmp <= 275.15) frzgra = .true. + endif + endif + + th2 = theta1(i) + q2 = q0(i) + +! 3. other forcing (input) data (i): +! ------------------------------ +! sfcspd - wind speed (m s-1) at height zlvl above ground +! q2sat - sat mixing ratio at height zlvl above ground (kg kg-1) +! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (kg kg-1 k-1) + + uu = u1(i) + vv = v1(i) + + 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) + + shdmin1d = shdmin(i) + shdmax1d = shdmax(i) + snoalb1d = snoalb(i) + + alb = sfalb(i) + + tbot = tg3(i) + ptu = 0.0 + + + cmc = canopy(i)/1000. ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter + + snowh = snwdph(i) * 0.001 ! convert from mm to m + sneqv = weasd(i) * 0.001 ! convert from mm to m + + + +! 5. history (state) variables (h): +! ------------------------------ +! cmc - canopy moisture content (m) +! t1 - ground/canopy/snowpack) effective skin temperature (k) -> tsea +! stc(nsoil) - soil temp (k) -> stsoil +! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil +! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil +! snowh - actual snow depth (m) +! sneqv - liquid water-equivalent snow depth (m) +! albedo - surface albedo including snow effect (unitless fraction) +! ch - surface exchange coefficient for heat and moisture (m s-1) -> chx +! cm - surface exchange coefficient for momentum (m s-1) -> cmx + + isnowx = nint(snowxy(i)) + tvx = tvxy(i) + tgx = tgxy(i) + canliqx = canliqxy(i) !in mm + canicex = canicexy(i) + + eahxy(i) = (ps(i)*q2)/(0.622+q2) ! use q0 to reinit; + eahx = eahxy(i) + tahx = tahxy(i) + + co2pp = co2_table * sfcprs + o2pp = o2_table * sfcprs + fwetx = fwetxy(i) + + sneqvox = sneqvoxy(i) + alboldx = alboldxy(i) + + qsnowx = qsnowxy(i) + wslakex = wslakexy(i) + + zwtx = zwtxy(i) + wax = waxy(i) + wtx = waxy(i) + + do k = -2,0 + tsnsoxy(i,k) = tsnoxy(i,k) + enddo + + do k = 1,4 + tsnsoxy(i,k) = stc(i,k) + enddo + + do k = -2,0 + snicex(k) = snicexy(i,k) ! in k/m3; mm + snliqx(k) = snliqxy(i,k) ! in k/m3; mm + tsnox (k) = tsnoxy(i,k) + + ficeold(k) = 0.0 ! derived + + if (snicex(k) > 0.0 ) then + ficeold(k) = snicex(k) /(snicex(k)+snliqx(k)) + + endif + enddo + + do k = -2, km + zsnsox(k) = zsnsoxy(i,k) + tsnsox(k) = tsnsoxy(i,k) + enddo + + lfmassx = lfmassxy(i) + rtmassx = rtmassxy(i) + stmassx = stmassxy(i) + + woodx = woodxy(i) + stblcpx = stblcpxy(i) + fastcpx = fastcpxy(i) + + xsaix = xsaixy(i) + xlaix = xlaixy(i) + + taussx = taussxy(i) + + qsfc1d = undefined ! derive later, it is an in/out? + swe = weasd(i) + + do k = 1, km + smoiseqx(k) = smoiseq(i,k) + enddo + + smcwtdx = smcwtdxy(i) + rechx = rechxy(i) + deeprechx = deeprechxy(i) +!-- +! the optional details for precip +!-- + +! pconv = 0. ! convective - may introduce later +! pnonc = (1 - ffrozp) * prcp ! large scale total in mm/s; +! pshcv = 0. +! psnow = ffrozp * prcp /10.0 ! snow = qsnowx? +! pgrpl = 0. +! phail = 0. + pnonc = rainn_mp(i) + pconv = rainc_mp(i) + pshcv = 0. + psnow = snow_mp(i) + pgrpl = graupel_mp(i) + phail = ice_mp(i) +! +!-- old +! + 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 ! convert from mm to m + + if (swe /= 0.0 .and. snowh == 0.0) then + snowh = 10.0 * swe /1000.0 + endif + + chx = chxy(i) ! maybe chxy + cmx = cmxy(i) + + chh(i) = ch(i) * wind(i) * rho(i) + cmm(i) = cm(i) * wind(i) + + + + call transfer_mp_parameters(vtype,stype,slope,isc,parameters) + + call noahmp_options(idveg ,iopt_crs,iopt_btr,iopt_run,iopt_sfc, & + & iopt_frz,iopt_inf,iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc) + + + if ( vtype == isice_table ) then + + ice = -1 + tbot = min(tbot,263.15) + + call noahmp_options_glacier & + & (idveg ,iopt_crs ,iopt_btr, iopt_run ,iopt_sfc ,iopt_frz, & + & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + call noahmp_glacier ( & + & i ,1 ,cosz ,nsnow ,nsoil ,delt , & ! in : time/space/model-related + & sfctmp ,sfcprs ,uu ,vv ,q2 ,swdn , & ! in : forcing + & prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + & qsnowx ,sneqvox ,alboldx ,cmx ,chx ,isnowx, & ! in/out :sneqvox + alboldx -LST + & swe ,smsoil ,zsnsox ,snowh ,snicex ,snliqx , & ! in/out : sneqvx + snowhx are avgd + & tgx ,tsnsox ,slsoil ,taussx ,qsfc1d , & ! in/out : + & fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + & trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : albedo is surface albedo + & qsnbot ,ponding ,ponding1,ponding2,t2mb ,q2b , & ! out : + & emissi ,fpice ,ch2b ,esnow ) + +! +! in/out and outs +! + + fsno = 1.0 + + tvx = undefined + canicex = undefined + canliqx = undefined + eahx = undefined + tahx = undefined + + fwetx = undefined + wslakex = undefined + zwtx = undefined + wax = undefined + wtx = undefined + + lfmassx = undefined + rtmassx = undefined + stmassx = undefined + woodx = undefined + stblcpx = undefined + fastcpx = undefined + xlaix = undefined + xsaix = undefined + + smcwtdx = 0.0 + rechx = 0.0 + deeprechx = 0.0 + + do k = 1,4 + smoiseqx(k) = smsoil(k) + enddo + + fctr = undefined + fcev = undefined + + z0wrf = 0.002 + + eta = fgev + t2mmp(i) = t2mb + q2mp(i) = q2b +! +! Non-glacial case +! + else + ice = 0 + +! write(*,*)'tsnsox(1)=',tsnsox,'tgx=',tgx + call noahmp_sflx (parameters ,& + & i , 1 , lat , iyrlen , julian , cosz ,& ! in : time/space-related + & delt , dx , dz8w , nsoil , zsoil , nsnow ,& ! in : model configuration + & shdfac , shdmax1d, vtype , ice , ist ,& ! in : vegetation/soil + & smoiseqx ,& ! in + & sfctmp , sfcprs , psfc , uu , vv , q2 ,& ! in : forcing + & qc , swdn , lwdn ,& ! in : forcing + & pconv , pnonc , pshcv , psnow , pgrpl , phail ,& ! in : forcing + & tbot , co2pp , o2pp , foln , ficeold , zlvl ,& ! in : forcing + & alboldx , sneqvox ,& ! in/out : + & tsnsox , slsoil , smsoil , tahx , eahx , fwetx ,& ! in/out : + & canliqx , canicex , tvx , tgx , qsfc1d , qsnowx ,& ! in/out : + & isnowx , zsnsox , snowh , swe , snicex , snliqx ,& ! in/out : + & zwtx , wax , wtx , wslakex , lfmassx , rtmassx,& ! in/out : + & stmassx , woodx , stblcpx , fastcpx , xlaix ,xsaix ,& ! in/out : + & cmx , chx , taussx ,& ! in/out : + & smcwtdx ,deeprechx, rechx ,& ! in/out : + & z0wrf ,& ! out + & fsa , fsr , fira , fsh , ssoil , fcev ,& ! out : + & fgev , fctr , ecan , etran , edir , trad ,& ! out : + & tgb , tgv , t2mv , t2mb , q2v , q2b ,& ! out : + & runsrf , runsub , apar , psn , sav , sag ,& ! out : + & fsno , nee , gpp , npp , fveg , albedo ,& ! out : + & qsnbot , ponding , ponding1, ponding2, rssun , rssha ,& ! out : + & bgap , wgap , chv , chb , emissi ,& ! out : + & shg , shc , shb , evg , evb , ghv ,&! out : + & ghb , irg , irc , irb , tr , evc ,& ! out : + & chleaf , chuc , chv2 , chb2 , fpice , pahv ,& ! out + & pahg , pahb , pah , esnow ) + + + eta = fcev + fgev + fctr ! the flux w/m2 + + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) + + endif ! glacial split ends + +! +! mp in/out +! + snowxy (i) = float(isnowx) + tvxy (i) = tvx + tgxy (i) = tgx + canliqxy (i) = canliqx + canicexy (i) = canicex + eahxy (i) = eahx + tahxy (i) = tahx + + cmxy (i) = cmx + chxy (i) = chx + + fwetxy (i) = fwetx + sneqvoxy (i) = sneqvox + alboldxy (i) = alboldx + qsnowxy (i) = qsnowx + + wslakexy (i) = wslakex + zwtxy (i) = zwtx + waxy (i) = wax + wtxy (i) = wtx + + do k = -2,0 + tsnoxy (i,k) = tsnsox(k) + snicexy (i,k) = snicex (k) + snliqxy (i,k) = snliqx (k) + enddo + + do k = -2,4 + zsnsoxy (i,k) = zsnsox(k) + enddo + + lfmassxy (i) = lfmassx + rtmassxy (i) = rtmassx + stmassxy (i) = stmassx + woodxy (i) = woodx + stblcpxy (i) = stblcpx + fastcpxy (i) = fastcpx + + xlaixy (i) = xlaix + xsaixy (i) = xsaix + + taussxy (i) = taussx + + rechxy (i) = rechx + deeprechxy(i) = deeprechx + smcwtdxy(i) = smcwtdx + smoiseq(i,1:4) = smoiseqx(1:4) + +! +! generic in/outs +! + do k = 1, km + stc(i,k) = tsnsox(k) + smc(i,k) = smsoil(k) + slc(i,k) = slsoil(k) + enddo + + canopy(i) = canicex + canliqx + weasd(i) = swe + snwdph(i) = snowh * 1000.0 + +! write(*,*) 'swe,snowh,can' +! write (*,*) swe,snowh*1000.0,canopy(i) +! + smcmax = smcmax_table(stype) + smcref = smcref_table(stype) + smcwlt = smcdry_table(stype) +! +! outs +! + wet1(i) = smsoil(1) / smcmax + smcwlt2(i) = smcwlt + smcref2(i) = smcref + + runoff(i) = runsrf + drain(i) = runsub + + zorl(i) = z0wrf * 100.0 + + sncovr1(i) = fsno + snowc (i) = fsno + + sbsno(i) = esnow + gflux(i) = -1.0*ssoil + hflx(i) = fsh + evbs(i) = fgev + evcw(i) = fcev + trans(i) = fctr + evap(i) = eta + +! write(*,*) 'vtype, stype are',vtype,stype +! write(*,*) 'fsh,gflx,eta',fsh,ssoil,eta +! write(*,*) 'esnow,runsrf,runsub',esnow,runsrf,runsub +! write(*,*) 'evbs,evcw,trans',fgev,fcev,fctr +! write(*,*) 'snowc',fsno + + tsurf(i) = trad + + stm(i) = 0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & + & 1.0*smsoil(4) +! + snohf (i) = qsnbot * con_hfus ! only part of it but is diagnostic +! write(*,*) 'snohf',snohf(i) + + fdown = fsa + lwdn + t2v = sfctmp * (1.0 + 0.61*q2) +! ssoil = -1.0 *ssoil + + call penman (sfctmp,sfcprs,chx,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp,dqsdt2,emissi,fsno) + + ep(i) = etp + + endif ! end if_flag_iter_and_flag_block + enddo ! end do_i_loop + +! --- ... compute qsurf (specific humidity at sfc) + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rch(i) = rho(i) * con_cp * ch(i) * wind(i) + qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + +! --- ... restore land-related prognostic fields for guess run + + do i = 1, im + if (flag(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) + + + snowxy(i) = snow_old(i) + tvxy(i) = tv_old(i) + tgxy(i) = tg_old(i) + + canicexy(i) = canice_old(i) + canliqxy(i) = canliq_old(i) + eahxy(i) = eah_old(i) + tahxy(i) = tah_old(i) + fwetxy(i) = fwet_old(i) + sneqvoxy(i) = sneqvo_old(i) + alboldxy(i) = albold_old(i) + qsnowxy(i) = qsnow_old(i) + wslakexy(i) = wslake_old(i) + zwtxy(i) = zwt_old(i) + waxy(i) = wa_old(i) + wtxy(i) = wt_old(i) + lfmassxy(i) = lfmass_old(i) + rtmassxy(i) = rtmass_old(i) + stmassxy(i) = stmass_old(i) + woodxy(i) = wood_old(i) + stblcpxy(i) = stblcp_old(i) + fastcpxy(i) = fastcp_old(i) + xlaixy(i) = xlai_old(i) + xsaixy(i) = xsai_old(i) + taussxy(i) = tauss_old(i) + smcwtdxy(i) = smcwtd_old(i) + deeprechxy(i) = deeprech_old(i) + rechxy(i) = rech_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 +! + do k = 1, km + smoiseq(i,k) = smoiseq_old(i,k) + enddo + + do k = -2,0 + tsnoxy(i,k) = tsno_old(i,k) + snicexy(i,k) = snice_old(i,k) + snliqxy(i,k) = snliq_old(i,k) + enddo + + do k = -2,4 + zsnsoxy(i,k) = zsnso_old(i,k) + enddo + else + tskin(i) = tsurf(i) + endif + endif + enddo +! + return +!................................... + end subroutine noahmpdrv +!----------------------------------- + + subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & + & soilcolor,parameters) + + use noahmp_tables + use module_sf_noahmplsm + + implicit none + + integer, intent(in) :: vegtype + integer, intent(in) :: soiltype + integer, intent(in) :: slopetype + integer, intent(in) :: soilcolor + + type (noahmp_parameters), intent(out) :: parameters + + real :: refdk + real :: refkdt + real :: frzk + real :: frzfact + + parameters%iswater = iswater_table + parameters%isbarren = isbarren_table + parameters%isice = isice_table + parameters%eblforest = eblforest_table + +!-----------------------------------------------------------------------& + parameters%urban_flag = .false. + if( vegtype == isurban_table .or. vegtype == 31 & + & .or.vegtype == 32 .or. vegtype == 33) then + parameters%urban_flag = .true. + endif + +!------------------------------------------------------------------------------------------! +! transfer veg parameters +!------------------------------------------------------------------------------------------! + + parameters%ch2op = ch2op_table(vegtype) !maximum intercepted h2o per unit lai+sai (mm) + parameters%dleaf = dleaf_table(vegtype) !characteristic leaf dimension (m) + parameters%z0mvt = z0mvt_table(vegtype) !momentum roughness length (m) + parameters%hvt = hvt_table(vegtype) !top of canopy (m) + parameters%hvb = hvb_table(vegtype) !bottom of canopy (m) + parameters%den = den_table(vegtype) !tree density (no. of trunks per m2) + parameters%rc = rc_table(vegtype) !tree crown radius (m) + parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () + parameters%saim = saim_table(vegtype,:) !monthly stem area index, one-sided + parameters%laim = laim_table(vegtype,:) !monthly leaf area index, one-sided + parameters%sla = sla_table(vegtype) !single-side leaf area per kg [m2/kg] + parameters%dilefc = dilefc_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%dilefw = dilefw_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%fragr = fragr_table(vegtype) !fraction of growth respiration !original was 0.3 + parameters%ltovrc = ltovrc_table(vegtype) !leaf turnover [1/s] + + parameters%c3psn = c3psn_table(vegtype) !photosynthetic pathway: 0. = c4, 1. = c3 + parameters%kc25 = kc25_table(vegtype) !co2 michaelis-menten constant at 25c (pa) + parameters%akc = akc_table(vegtype) !q10 for kc25 + parameters%ko25 = ko25_table(vegtype) !o2 michaelis-menten constant at 25c (pa) + parameters%ako = ako_table(vegtype) !q10 for ko25 + parameters%vcmx25 = vcmx25_table(vegtype) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + parameters%avcmx = avcmx_table(vegtype) !q10 for vcmx25 + parameters%bp = bp_table(vegtype) !minimum leaf conductance (umol/m**2/s) + parameters%mp = mp_table(vegtype) !slope of conductance-to-photosynthesis relationship + parameters%qe25 = qe25_table(vegtype) !quantum efficiency at 25c (umol co2 / umol photon) + parameters%aqe = aqe_table(vegtype) !q10 for qe25 + parameters%rmf25 = rmf25_table(vegtype) !leaf maintenance respiration at 25c (umol co2/m**2/s) + parameters%rms25 = rms25_table(vegtype) !stem maintenance respiration at 25c (umol co2/kg bio/s) + parameters%rmr25 = rmr25_table(vegtype) !root maintenance respiration at 25c (umol co2/kg bio/s) + parameters%arm = arm_table(vegtype) !q10 for maintenance respiration + parameters%folnmx = folnmx_table(vegtype) !foliage nitrogen concentration when f(n)=1 (%) + parameters%tmin = tmin_table(vegtype) !minimum temperature for photosynthesis (k) + + parameters%xl = xl_table(vegtype) !leaf/stem orientation index + parameters%rhol = rhol_table(vegtype,:) !leaf reflectance: 1=vis, 2=nir + parameters%rhos = rhos_table(vegtype,:) !stem reflectance: 1=vis, 2=nir + parameters%taul = taul_table(vegtype,:) !leaf transmittance: 1=vis, 2=nir + parameters%taus = taus_table(vegtype,:) !stem transmittance: 1=vis, 2=nir + + parameters%mrp = mrp_table(vegtype) !microbial respiration parameter (umol co2 /kg c/ s) + parameters%cwpvt = cwpvt_table(vegtype) !empirical canopy wind parameter + + parameters%wrrat = wrrat_table(vegtype) !wood to non-wood ratio + parameters%wdpool = wdpool_table(vegtype) !wood pool (switch 1 or 0) depending on woody or not [-] + parameters%tdlef = tdlef_table(vegtype) !characteristic t for leaf freezing [k] + + parameters%nroot = nroot_table(vegtype) !number of soil layers with root present + parameters%rgl = rgl_table(vegtype) !parameter used in radiation stress function + parameters%rsmin = rs_table(vegtype) !minimum stomatal resistance [s m-1] + parameters%hs = hs_table(vegtype) !parameter used in vapor pressure deficit function + parameters%topt = topt_table(vegtype) !optimum transpiration air temperature [k] + parameters%rsmax = rsmax_table(vegtype) !maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! transfer rad parameters +!------------------------------------------------------------------------------------------! + + parameters%albsat = albsat_table(soilcolor,:) + parameters%albdry = albdry_table(soilcolor,:) + parameters%albice = albice_table + parameters%alblak = alblak_table + parameters%omegas = omegas_table + parameters%betads = betads_table + parameters%betais = betais_table + parameters%eg = eg_table + +!------------------------------------------------------------------------------------------! +! transfer global parameters +!------------------------------------------------------------------------------------------! + + parameters%co2 = co2_table + parameters%o2 = o2_table + parameters%timean = timean_table + parameters%fsatmx = fsatmx_table + parameters%z0sno = z0sno_table + parameters%ssi = ssi_table + parameters%swemx = swemx_table + +! ---------------------------------------------------------------------- +! transfer soil parameters +! ---------------------------------------------------------------------- + + parameters%bexp = bexp_table (soiltype) + parameters%dksat = dksat_table (soiltype) + parameters%dwsat = dwsat_table (soiltype) + parameters%f1 = f1_table (soiltype) + parameters%psisat = psisat_table (soiltype) + parameters%quartz = quartz_table (soiltype) + parameters%smcdry = smcdry_table (soiltype) + parameters%smcmax = smcmax_table (soiltype) + parameters%smcref = smcref_table (soiltype) + parameters%smcwlt = smcwlt_table (soiltype) + +! ---------------------------------------------------------------------- +! transfer genparm parameters +! ---------------------------------------------------------------------- + parameters%csoil = csoil_table + parameters%zbot = zbot_table + parameters%czil = czil_table + + frzk = frzk_table + refdk = refdk_table + refkdt = refkdt_table + parameters%kdt = refkdt * parameters%dksat / refdk + parameters%slope = slope_table(slopetype) + + if(parameters%urban_flag)then ! hardcoding some urban parameters for soil + parameters%smcmax = 0.45 + parameters%smcref = 0.42 + parameters%smcwlt = 0.40 + parameters%smcdry = 0.40 + parameters%csoil = 3.e6 + endif + + ! adjust frzk parameter to actual soil type: frzk * frzfact + +!-----------------------------------------------------------------------& + if(soiltype /= 14) then + frzfact = (parameters%smcmax / parameters%smcref) & + & * (0.412 / 0.468) + parameters%frzx = frzk * frzfact + end if + + end subroutine transfer_mp_parameters + +!-----------------------------------------------------------------------& + + + subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp, & + & dqsdt2,emissi_in,sncovr) + +! etp is calcuated right after ssoil + +! ---------------------------------------------------------------------- +! subroutine penman +! ---------------------------------------------------------------------- +! calculate potential evaporation for the current point. various +! partial sums/products are also calculated and passed back to the +! calling routine for later use. +! ---------------------------------------------------------------------- + implicit none + logical, intent(in) :: snowng, frzgra + real, intent(in) :: ch, dqsdt2,fdown,prcp,ffrozp, & + & q2, q2sat,ssoil, sfcprs, sfctmp, & + & t2v, th2,emissi_in,sncovr + real, intent(out) :: etp + real :: epsca,flx2,rch,rr,t24 + real :: a, delta, fnet,rad,rho,emissi,elcp1,lvs + + real, parameter :: elcp = 2.4888e+3, lsubc = 2.501000e+6,cp = 1004.6 + real, parameter :: lsubs = 2.83e+6, rd = 287.05, cph2o = 4.1855e+3 + real, parameter :: cpice = 2.106e+3, lsubf = 3.335e5 + real, parameter :: sigma = 5.6704e-8 + +! ---------------------------------------------------------------------- +! executable code begins here: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! prepare partial quantities for penman equation. +! ---------------------------------------------------------------------- + emissi=emissi_in +! elcp1 = (1.0-sncovr)*elcp + sncovr*elcp*lsubs/lsubc + lvs = (1.0-sncovr)*lsubc + sncovr*lsubs + + flx2 = 0.0 + delta = elcp * dqsdt2 +! delta = elcp1 * dqsdt2 + t24 = sfctmp * sfctmp * sfctmp * sfctmp + rr = t24 * 6.48e-8 / (sfcprs * ch) + 1.0 +! rr = emissi*t24 * 6.48e-8 / (sfcprs * ch) + 1.0 + rho = sfcprs / (rd * t2v) + +! ---------------------------------------------------------------------- +! adjust the partial sums / products with the latent heat +! effects caused by falling precipitation. +! ---------------------------------------------------------------------- + rch = rho * cp * ch + if (.not. snowng) then + if (prcp > 0.0) rr = rr + cph2o * prcp / rch + else +! ---- ... fractional snowfall/rainfall + rr = rr + (cpice*ffrozp+cph2o*(1.-ffrozp)) & + & *prcp/rch + end if + +! ---------------------------------------------------------------------- +! include the latent heat effects of frzng rain converting to ice on +! impact in the calculation of flx2 and fnet. +! ---------------------------------------------------------------------- +! fnet = fdown - sigma * t24- ssoil + fnet = fdown - emissi*sigma * t24- ssoil + if (frzgra) then + flx2 = - lsubf * prcp + fnet = fnet - flx2 +! ---------------------------------------------------------------------- +! finish penman equation calculations. +! ---------------------------------------------------------------------- + end if + rad = fnet / rch + th2- sfctmp + a = elcp * (q2sat - q2) +! a = elcp1 * (q2sat - q2) + epsca = (a * rr + rad * delta) / (delta + rr) + etp = epsca * rch / lsubc +! etp = epsca * rch / lvs + +! ---------------------------------------------------------------------- + end subroutine penman + + diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta new file mode 100644 index 000000000..257963b31 --- /dev/null +++ b/physics/sfc_noahmp_drv.meta @@ -0,0 +1,1069 @@ +[ccpp-arg-table] + name = lsm_noahmp_run + type = scheme +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + 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 +[itime] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F +[ps] + standard_name = surface_air_pressure + long_name = surface pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[t1] + standard_name = air_temperature_at_lowest_model_layer + long_name = mean temperature at lowest model layer + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[q1] + standard_name = water_vapor_specific_humidity_at_lowest_model_layer + long_name = water vapor specific humidity at lowest model layer + units = kg kg-1 + dimensions = (horizontal_dimension) + 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_dimension) + type = integer + intent= in + optional = F +[vegtype] + standard_name = vegetation_type_classification + long_name = vegetation type at each grid cell + units = index + dimensions = (horizontal_dimension) + 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_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[sfcemis] + standard_name = surface_longwave_emissivity + long_name = surface lw emissivity in fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[dlwflx] + standard_name = surface_downwelling_longwave_flux_absorbed_by_ground + long_name = total sky surface downward longwave flux absorbed by the ground + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[dswsfc] + standard_name = surface_downwelling_shortwave_flux + long_name = surface downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent= in + optional = F +[snet] + standard_name = surface_net_downwelling_shortwave_flux + long_name = surface net downwelling shortwave flux at current time + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[delt] + standard_name = time_step_for_dynamics + long_name = dynamics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[tg3] + standard_name = deep_soil_temperature + long_name = deep soil temperature + units = K + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl1] + standard_name = air_pressure_at_lowest_model_layer + long_name = mean pressure at lowest model layer + units = Pa + dimensions = (horizontal_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zf] + standard_name = height_above_ground_at_lowest_model_layer + long_name = layer 1 height above ground (not MSL) + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + 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_dimension) + type = logical + intent = in + optional = F +[ddvel] + standard_name = surface_wind_enhancement_due_to_convection + long_name = surface wind enhancement due to convection + units = m s-1 + dimensions = (horizontal_dimension) + 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_dimension) + type = integer + intent = in + optional = F +[shdmin] + standard_name = minimum_vegetation_area_fraction + long_name = min fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[shdmax] + standard_name = maximum_vegetation_area_fraction + long_name = max fractional coverage of green vegetation + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snoalb] + standard_name = upper_bound_on_max_albedo_over_deep_snow + long_name = maximum snow albedo + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sfalb] + standard_name = surface_diffused_shortwave_albedo + long_name = mean surface diffused sw albedo + units = frac + dimensions = (horizontal_dimension) + 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_dimension) + type = logical + intent = in + optional = F +[flag_guess] + standard_name = flag_for_guess_run + long_name = flag for guess run + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[idveg] + standard_name = flag_for_dynamic_vegetation_option + long_name = choice for dynamic vegetation option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_crs] + standard_name = flag_for_canopy_stomatal_resistance_option + long_name = choice for canopy stomatal resistance option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_btr] + standard_name = flag_for_soil_moisture_factor_stomatal_resistance_option + long_name = choice for soil moisture factor for canopy stomatal resistance option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_run] + standard_name = flag_for_runoff_and_groundwater_option + long_name = choice for runoff and groundwater option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_sfc] + standard_name = flag_for_surface_layer_drag_coefficient_option + long_name = choice for surface layer drag coefficient option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_frz] + standard_name = flag_for_supercooled_liquid_water_option + long_name = choice for supercooled liquid water option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_inf] + standard_name = flag_for_frozen_soil_permeability_option + long_name = choice for frozen soil permeability option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_rad] + standard_name = flag_for_radiation_transfer_option + long_name = choice for radiation transfer option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_alb] + standard_name = flag_for_ground_snow_surface_albedo_option + long_name = choice for ground snow surface albedo option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_snf] + standard_name = flag_for_precipitation_partition_option + long_name = choice for precipitation partition option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_tbot] + standard_name = flag_for_lower_boundary_soil_temperature_option + long_name = choice for lower boundary soil temperature option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[iopt_stc] + standard_name = flag_for_soil_and_snow_temperature_time_stepping_option + long_name = choice for soil and snow temperature time stepping option (see noahmp module for definition) + units = index + dimensions = () + type = integer + intent = in + optional = F +[xlat] + standard_name = latitude + long_name = latitude + units = radians + dimensions = (horizontal_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[iyrlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rainn_mp] + standard_name = explicit_rainfall_rate_from_previous_timestep + long_name = explicit rainfall rate previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rainc_mp] + standard_name = convective_precipitation_rate_from_previous_timestep + long_name = convective precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snow_mp] + standard_name = snow_precipitation_rate_from_previous_timestep + long_name = snow precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[graupel_mp] + standard_name = graupel_precipitation_rate_from_previous_timestep + long_name = graupel precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ice_mp] + standard_name = ice_precipitation_rate_from_previous_timestep + long_name = ice precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + 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_dimension) + 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_dimension) + 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_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smc] + standard_name = volume_fraction_of_soil_moisture + long_name = total soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stc] + standard_name = soil_temperature + long_name = soil temperature + units = K + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slc] + standard_name = volume_fraction_of_unfrozen_soil_moisture + long_name = liquid soil moisture + units = frac + dimensions = (horizontal_dimension,soil_vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canopy] + standard_name = canopy_water_amount + long_name = canopy water amount + units = mm + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snowxy] + standard_name = number_of_snow_layers + long_name = number of snow layers + units = count + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tvxy] + standard_name = vegetation_temperature + long_name = vegetation temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tgxy] + standard_name = ground_temperature_for_noahmp + long_name = ground temperature for noahmp + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canicexy] + standard_name = canopy_intercepted_ice_mass + long_name = canopy intercepted ice mass + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[canliqxy] + standard_name = canopy_intercepted_liquid_water + long_name = canopy intercepted liquid water + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[eahxy] + standard_name = canopy_air_vapor_pressure + long_name = canopy air vapor pressure + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tahxy] + standard_name = canopy_air_temperature + long_name = canopy air temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cmxy] + standard_name = surface_drag_coefficient_for_momentum_for_noahmp + long_name = surface drag coefficient for momentum for noahmp + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[chxy] + standard_name = surface_drag_coefficient_for_heat_and_moisture_for_noahmp + long_name = surface exchange coeff heat & moisture for noahmp + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fwetxy] + standard_name = area_fraction_of_wet_canopy + long_name = area fraction of canopy that is wetted/snowed + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[sneqvoxy] + standard_name = snow_mass_at_previous_time_step + long_name = snow mass at previous time step + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[alboldxy] + standard_name = snow_albedo_at_previous_time_step + long_name = snow albedo at previous time step + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qsnowxy] + standard_name = snow_precipitation_rate_at_surface + long_name = snow precipitation rate at surface + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wslakexy] + standard_name = lake_water_storage + long_name = lake water storage + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[zwtxy] + standard_name = water_table_depth + long_name = water table depth + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[waxy] + standard_name = water_storage_in_aquifer + long_name = water storage in aquifer + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[wtxy] + standard_name = water_storage_in_aquifer_and_saturated_soil + long_name = water storage in aquifer and saturated soil + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[tsnoxy] + standard_name = snow_temperature + long_name = snow_temperature + units = K + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[zsnsoxy] + standard_name = layer_bottom_depth_from_snow_surface + long_name = depth from the top of the snow surface at the bottom of the layer + units = m + dimensions = (horizontal_dimension, -2:4) + type = real + kind = kind_phys + intent = inout + optional = F +[snicexy] + standard_name = snow_layer_ice + long_name = snow_layer_ice + units = mm + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[snliqxy] + standard_name = snow_layer_liquid_water + long_name = snow layer liquid water + units = mm + dimensions = (horizontal_dimension, -2:0) + type = real + kind = kind_phys + intent = inout + optional = F +[lfmassxy] + standard_name = leaf_mass + long_name = leaf mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rtmassxy] + standard_name = fine_root_mass + long_name = fine root mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stmassxy] + standard_name = stem_mass + long_name = stem mass + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[woodxy] + standard_name = wood_mass + long_name = wood mass including woody roots + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stblcpxy] + standard_name = slow_soil_pool_mass_content_of_carbon + long_name = stable carbon in deep soil + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fastcpxy] + standard_name = fast_soil_pool_mass_content_of_carbon + long_name = short-lived carbon in shallow soil + units = g m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xlaixy] + standard_name = leaf_area_index + long_name = leaf area index + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[xsaixy] + standard_name = stem_area_index + long_name = stem area index + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[taussxy] + standard_name = nondimensional_snow_age + long_name = non-dimensional snow age + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[smoiseq] + standard_name = equilibrium_soil_water_content + long_name = equilibrium soil water content + units = m3 m-3 + dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) + type = real + kind = kind_phys + intent = inout + optional = F +[smcwtdxy] + standard_name = soil_water_content_between_soil_bottom_and_water_table + long_name = soil water content between the bottom of the soil and the water table + units = m3 m-3 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[deeprechxy] + standard_name = water_table_recharge_when_deep + long_name = recharge to or from the water table when deep + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rechxy] + standard_name = water_table_recharge_when_shallow + long_name = recharge to or from the water table when shallow + units = m + dimensions = (horizontal_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[evbs] + standard_name = soil_upward_latent_heat_flux + long_name = soil upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[evcw] + standard_name = canopy_upward_latent_heat_flux + long_name = canopy upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[snowc] + standard_name = surface_snow_area_fraction + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[stm] + standard_name = soil_moisture_content + long_name = soil moisture + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[smcwlt2] + standard_name = volume_fraction_of_condensed_water_in_soil_at_wilting_point + long_name = wilting point (volumetric) + units = frac + dimensions = (horizontal_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[wet1] + standard_name = normalized_soil_wetness + long_name = normalized soil wetness + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[t2mmp] + standard_name = temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[q2mp] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 6236796165e63dd851f13ba6cfea970e120f6d0d Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 20 Aug 2019 14:34:57 -0600 Subject: [PATCH 02/36] put sfc_noahmp_drv.f in module; add init/finalize + meta file html breadcrumb --- physics/sfc_noahmp_drv.f | 29 ++++++++++++++++++++++++++--- physics/sfc_noahmp_drv.meta | 6 +++--- 2 files changed, 29 insertions(+), 6 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 8d12d8fa4..f12d9df06 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -1,5 +1,28 @@ +!> \file sfc_noahmp_drv.f +!! This file contains the NoahMP land surface scheme driver. + +!> This module contains the CCPP-compliant NoahMP land surface scheme driver. + module noahmpdrv + + implicit none + + private + + public :: noahmpdrv_init, noahmpdrv_run, noahmpdrv_finalize + + contains + + subroutine noahmpdrv_init + end subroutine noahmpdrv_init + + subroutine noahmpdrv_finalize + end subroutine noahmpdrv_finalize + +!> \section arg_table_noahmpdrv_run Argument Table +!! \htmlinclude noahmpdrv_run.html +!! !----------------------------------- - subroutine noahmpdrv & + subroutine noahmpdrv_run & !................................... ! --- inputs: & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & @@ -890,7 +913,7 @@ subroutine noahmpdrv & ! return !................................... - end subroutine noahmpdrv + end subroutine noahmpdrv_run !----------------------------------- subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & @@ -1139,4 +1162,4 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end subroutine penman - +end module noahmpdrv diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 257963b31..f9b199f79 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -522,7 +522,7 @@ [canopy] standard_name = canopy_water_amount long_name = canopy water amount - units = mm + units = kg m-2 dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -891,7 +891,7 @@ [drain] standard_name = subsurface_runoff_flux long_name = subsurface runoff flux - units = mm s-1 + units = kg m-2 s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys @@ -927,7 +927,7 @@ [runoff] standard_name = surface_runoff_flux long_name = surface runoff flux - units = mm s-1 + units = kg m-2 s-1 dimensions = (horizontal_dimension) type = real kind = kind_phys From 747c5a4dde4af16761316355b6ae96e42ab3a5d2 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 21 Aug 2019 15:25:52 -0600 Subject: [PATCH 03/36] fix soil_moisture_content unit error --- physics/sfc_noahmp_drv.f | 6 +++--- physics/sfc_noahmp_drv.meta | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index f12d9df06..bdda3f947 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -809,8 +809,8 @@ subroutine noahmpdrv_run & tsurf(i) = trad - stm(i) = 0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & - & 1.0*smsoil(4) + stm(i) = (0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & + & 1.0*smsoil(4))*1000.0 ! unit conversion from m to kg m-2 ! snohf (i) = qsnbot * con_hfus ! only part of it but is diagnostic ! write(*,*) 'snohf',snohf(i) @@ -1162,4 +1162,4 @@ subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & ! ---------------------------------------------------------------------- end subroutine penman -end module noahmpdrv + end module noahmpdrv diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index f9b199f79..6667c7196 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -1,5 +1,5 @@ [ccpp-arg-table] - name = lsm_noahmp_run + name = noahmpdrv_run type = scheme [im] standard_name = horizontal_dimension @@ -990,7 +990,7 @@ [stm] standard_name = soil_moisture_content long_name = soil moisture - units = m + units = kg m-2 dimensions = (horizontal_dimension) type = real kind = kind_phys From aa5aec76500a6a3923b04a4530e27659ec81d3a8 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 21 Aug 2019 16:32:38 -0600 Subject: [PATCH 04/36] add CCPP error variables to sfc_noahmp_drv.f and fix local name error in meta file --- physics/sfc_noahmp_drv.f | 36 ++++++++++++++++++++++-------------- physics/sfc_noahmp_drv.meta | 4 ++-- 2 files changed, 24 insertions(+), 16 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index bdda3f947..26bdf6043 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -25,31 +25,31 @@ end subroutine noahmpdrv_finalize subroutine noahmpdrv_run & !................................... ! --- inputs: - & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & - & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & ( im, km, itime, ps, u1, v1, t1, q1, soiltyp, vegtype, & + & sigmaf, sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & & prsl1, prslki, zf, dry, ddvel, slopetyp, & & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & - & idveg,iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & - & iopt_inf,iopt_rad, iopt_alb, iopt_snf,iopt_tbot,iopt_stc, & - & xlatin,xcoszin, iyrlen, julian, & - & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp, & + & idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & + & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & + & iopt_stc, xlatin, xcoszin, iyrlen, julian, & + & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf,zorl, & + & canopy, trans, tsurf, zorl, & ! --- Noah MP specific - & snowxy, tvxy, tgxy, canicexy,canliqxy, eahxy,tahxy,cmxy, & - & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, & - & zwtxy, waxy, wtxy, tsnoxy,zsnsoxy, snicexy, snliqxy, & - & lfmassxy, rtmassxy,stmassxy, woodxy, stblcpxy, fastcpxy, & - & xlaixy,xsaixy,taussxy,smoiseq,smcwtdxy,deeprechxy,rechxy, & + & snowxy, tvxy, tgxy, canicexy, canliqxy, eahxy, tahxy, cmxy,& + & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, zwtxy,& + & waxy, wtxy, tsnoxy, zsnsoxy, snicexy, snliqxy, lfmassxy, & + & rtmassxy, stmassxy, woodxy, stblcpxy, fastcpxy, xlaixy, & + & xsaixy, taussxy, smoiseq, smcwtdxy, deeprechxy, rechxy, & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2,wet1,t2mmp,q2mp) + & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) ! ! use machine , only : kind_phys @@ -157,7 +157,11 @@ subroutine noahmpdrv_run & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & & t2mmp,q2mp - + +! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + ! --- locals: real (kind=kind_phys), dimension(im) :: rch, rho, & & q0, qs1, theta1, tv1, wind, weasd_old, snwdph_old, & @@ -228,6 +232,10 @@ subroutine noahmpdrv_run & !===> ... begin here ! +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + ! --- ... set flag for land points do i = 1, im diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 6667c7196..c84998cad 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -367,7 +367,7 @@ type = integer intent = in optional = F -[xlat] +[xlatin] standard_name = latitude long_name = latitude units = radians @@ -376,7 +376,7 @@ kind = kind_phys intent = in optional = F -[xcosz] +[xcoszin] standard_name = instantaneous_cosine_of_zenith_angle long_name = cosine of zenith angle at current time units = none From e5e6b787c2ee5a991ea3e9b9d7147d65546c3f6f Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 22 Aug 2019 13:34:16 -0600 Subject: [PATCH 05/36] add NoahMP interstitial code (only pre routine needed for GFS suite for handling dates) --- physics/noahmp_pre.F90 | 72 +++++++++++++++++++++++++++++++++++++ physics/noahmp_pre.meta | 45 +++++++++++++++++++++++ physics/sfc_noahmp_drv.f | 24 +++++++------ physics/sfc_noahmp_drv.meta | 36 +++++++++---------- 4 files changed, 149 insertions(+), 28 deletions(-) create mode 100644 physics/noahmp_pre.F90 create mode 100644 physics/noahmp_pre.meta diff --git a/physics/noahmp_pre.F90 b/physics/noahmp_pre.F90 new file mode 100644 index 000000000..13d432209 --- /dev/null +++ b/physics/noahmp_pre.F90 @@ -0,0 +1,72 @@ +!> \file noahmp_pre.F90 +!! This file contains subroutines that prepare data for the NoahMP land surface model scheme +!! as part of the GFS physics suite. + module noahmp_pre + + implicit none + + contains + + subroutine noahmp_pre_init() + end subroutine noahmp_pre_init + + subroutine noahmp_pre_finalize() + end subroutine noahmp_pre_finalize + +!> \section arg_table_noahmp_pre_run Argument Table +!! \htmlinclude noahmp_pre_run.html +!! + subroutine noahmp_pre_run (jdat, julian, yearlen, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: jdat(1:8) + + real(kind=kind_phys), intent(out) :: julian + integer , intent(out) :: yearlen + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd + + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + + end subroutine noahmp_pre_run + + end module noahmp_pre \ No newline at end of file diff --git a/physics/noahmp_pre.meta b/physics/noahmp_pre.meta new file mode 100644 index 000000000..a76fb1965 --- /dev/null +++ b/physics/noahmp_pre.meta @@ -0,0 +1,45 @@ +[ccpp-arg-table] + name = noahmp_pre_run + type = scheme +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + 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/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 26bdf6043..a33ac8eac 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -36,7 +36,7 @@ subroutine noahmpdrv_run & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf, zorl, & + & canopy, trans, tsurf, zorl, t2mmp, q2mp, & ! --- Noah MP specific @@ -49,7 +49,7 @@ subroutine noahmpdrv_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) + & smcwlt2, smcref2, wet1, errmsg, errflg) ! ! use machine , only : kind_phys @@ -129,7 +129,8 @@ subroutine noahmpdrv_run & ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & - & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf,zorl + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl, & + & t2mmp, q2mp real (kind=kind_phys), dimension(im,km), intent(inout) :: & & smc, stc, slc @@ -150,13 +151,12 @@ subroutine noahmpdrv_run & integer, dimension(im) :: jsnowxy real (kind=kind_phys),dimension(im) :: snodep real (kind=kind_phys),dimension(im,-2:4) :: tsnsoxy - + ! --- output: real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & - & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & - & t2mmp,q2mp + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1 ! error messages character(len=*), intent(out) :: errmsg @@ -669,8 +669,10 @@ subroutine noahmpdrv_run & z0wrf = 0.002 eta = fgev - t2mmp(i) = t2mb - q2mp(i) = q2b + if (dry(i)) then + t2mmp(i) = t2mb + q2mp(i) = q2b + endif ! ! Non-glacial case ! @@ -711,8 +713,10 @@ subroutine noahmpdrv_run & eta = fcev + fgev + fctr ! the flux w/m2 - t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) - q2mp(i) = q2v*fveg+q2b*(1-fveg) + if (dry(i)) then + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) + endif endif ! glacial split ends diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index c84998cad..2422cffb3 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -555,6 +555,24 @@ kind = kind_phys intent = inout optional = F +[t2mmp] + standard_name = temperature_at_2m + long_name = 2 meter temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[q2mp] + standard_name = specific_humidity_at_2m + long_name = 2 meter specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers @@ -1032,24 +1050,6 @@ kind = kind_phys intent = out optional = F -[t2mmp] - standard_name = temperature_at_2m - long_name = 2 meter temperature - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F -[q2mp] - standard_name = specific_humidity_at_2m - long_name = 2 meter specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6c2cab88ee8249d42e7645f7f8e966a1a5b47390 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 11:10:11 -0600 Subject: [PATCH 06/36] send physical constants through the argument list --- physics/sfc_noahmp_drv.f | 32 ++++++++------- physics/sfc_noahmp_drv.meta | 81 +++++++++++++++++++++++++++++++++++++ 2 files changed, 98 insertions(+), 15 deletions(-) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index a33ac8eac..1406ec366 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -33,6 +33,8 @@ subroutine noahmpdrv_run & & iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, & & iopt_stc, xlatin, xcoszin, iyrlen, julian, & & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & + & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & + & con_fvirt, con_rd, con_hfus, & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -55,8 +57,6 @@ subroutine noahmpdrv_run & use machine , only : kind_phys ! use date_def, only : idate use funcphys, only : fpvs - use physcons, only : con_g, con_hvap, con_cp, con_jcal, & - & con_eps, con_epsm1, con_fvirt, con_rd,con_hfus use module_sf_noahmplsm use module_sf_noahmp_glacier @@ -66,22 +66,12 @@ subroutine noahmpdrv_run & & saim_table,laim_table implicit none - -! --- constant parameters: - - real(kind=kind_phys), parameter :: cpinv = 1.0/con_cp - real(kind=kind_phys), parameter :: hvapi = 1.0/con_hvap - real(kind=kind_phys), parameter :: elocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: convrad = con_jcal*1.e4/60.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 real(kind=kind_phys), parameter :: a3 = 273.16 real(kind=kind_phys), parameter :: a4 = 35.86 real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) -! -! --- -! - + real, parameter :: undefined = -1.e36 real :: dz8w = undefined @@ -126,6 +116,10 @@ subroutine noahmpdrv_run & real (kind=kind_phys), intent(in) :: delt logical, dimension(im), intent(in) :: flag_iter, flag_guess + + real (kind=kind_phys), intent(in) :: con_hvap, con_cp, con_jcal, & + & rhoh2o, con_eps, con_epsm1, con_fvirt, & + & con_rd, con_hfus ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & @@ -225,12 +219,20 @@ subroutine noahmpdrv_run & integer :: i, k, ice, stype, vtype ,slope,nroot,couple logical :: flag(im) logical :: snowng,frzgra + + ! --- local derived constants: + real(kind=kind_phys) :: cpinv, hvapi, convrad, elocp + type(noahmp_parameters) :: parameters ! !===> ... begin here -! +! + cpinv = 1.0/con_cp + hvapi = 1.0/con_hvap + convrad = con_jcal*1.e4/60.0 + elocp = con_hvap/con_cp ! Initialize CCPP error handling variables errmsg = '' diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 2422cffb3..cd3b1e962 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -447,6 +447,87 @@ kind = kind_phys intent = in optional = F +[con_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 +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_jcal] + standard_name = joules_per_calorie_constant + long_name = joules per calorie constant + units = J cal-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rhoh2o] + standard_name = liquid_water_density + long_name = density of liquid water + units = kg m-3 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_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 +[con_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 +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land From 24b8942dd25f7c72015610dae10912676c002055 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 18:01:07 -0600 Subject: [PATCH 07/36] remove WRF error handling in favor of CCPP error handling --- physics/module_sf_noahmp_glacier.f90 | 48 ++++++++++- physics/module_sf_noahmplsm.f90 | 123 ++++++++++++++++++++++++++- physics/module_wrf_utl.f90 | 50 ----------- physics/sfc_noahmp_drv.f | 18 +++- 4 files changed, 181 insertions(+), 58 deletions(-) delete mode 100755 physics/module_wrf_utl.f90 diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index a26e108e4..35bad73d9 100755 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -111,7 +111,9 @@ end module noahmp_glacier_globals module noahmp_glacier_routines use noahmp_glacier_globals +#ifndef CCPP use module_wrf_utl +#endif implicit none public :: noahmp_options_glacier @@ -158,7 +160,12 @@ subroutine noahmp_glacier (& fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : qsnbot ,ponding ,ponding1,ponding2,t2m ,q2e , & ! out : +#ifdef CCPP + emissi, fpice ,ch2b , esnow, errmsg, errflg) +#else emissi, fpice ,ch2b , esnow) +#endif + ! -------------------------------------------------------------------------------------------------- ! initial code: guo-yue niu, oct. 2007 @@ -232,6 +239,11 @@ subroutine noahmp_glacier (& real , intent(out) :: ch2b real , intent(out) :: esnow +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! local integer :: iz !do-loop index integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] @@ -529,7 +541,15 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i fire = lwdn + fira - if(fire <=0.) call wrf_error_fatal("stop in noah-mp: emitted longwave <0") + if(fire <=0.) then +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp: emitted longwave <0" + return +#else + call wrf_error_fatal("stop in noah-mp: emitted longwave <0") +#endif + end if ! compute a net emissivity emissi = emg @@ -1252,7 +1272,13 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in if(zlvl <= zpd) then write(*,*) 'critical glacier problem: zlvl <= zpd; model stops', zlvl, zpd +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp glacier" + return +#else call wrf_error_fatal("stop in noah-mp glacier") +#endif endif tmpcm = log((zlvl-zpd) / z0m) @@ -2918,17 +2944,33 @@ subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & write(*,*) "fsa =",fsa write(*,*) "fsr =",fsr write(message,*) 'errsw =',errsw +#ifdef CCPP + errflg = 1 + errmsg = trim(message)//NEW_LINE('A')//"radiation budget problem in noahmp glacier" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("radiation budget problem in noahmp glacier") +#endif end if erreng = sag-(fira+fsh+fgev+ssoil) if(erreng > 0.01) then write(message,*) 'erreng =',erreng +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(i6,1x,i6,1x,5f10.4)')iloc,jloc,sag,fira,fsh,fgev,ssoil - call wrf_message(trim(message)) - call wrf_error_fatal("energy budget problem in noahmp glacier") +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//"energy budget problem in noahmp glacier" + return +#else + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp glacier") +#endif end if end_wb = sneqv diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 139c53277..791988a9a 100755 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -1,5 +1,7 @@ module module_sf_noahmplsm +#ifndef CCPP use module_wrf_utl +#endif implicit none @@ -303,7 +305,11 @@ subroutine noahmp_sflx (parameters, & shg , shc , shb , evg , evb , ghv , & ! out : ghb , irg , irc , irb , tr , evc , & ! out : chleaf , chuc , chv2 , chb2 , fpice , pahv , & - pahg , pahb , pah , esnow) +#ifdef CCPP + pahg , pahb , pah , esnow, errmsg, errflg) +#else + pahg , pahb , pah , esnow) +#endif ! -------------------------------------------------------------------------------------------------- ! initial code: guo-yue niu, oct. 2007 @@ -432,6 +438,10 @@ subroutine noahmp_sflx (parameters, & real :: q1 real, intent(out) :: emissi !jref:end +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! local integer :: iz !do-loop index @@ -606,7 +616,13 @@ subroutine noahmp_sflx (parameters, & if(fveg <= 0.05) fveg = 0.05 else write(*,*) "-------- fatal called in sflx -----------" +#ifdef CCPP + errflg = 1 + errmsg = "namelist parameter dveg unknown" + return +#else call wrf_error_fatal("namelist parameter dveg unknown") +#endif endif if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0 if(elai+esai == 0.0) fveg = 0.0 @@ -1271,36 +1287,89 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & write(*,*) "fsa =",fsa !jref:end write(message,*) 'errsw =',errsw +#ifdef CCPP + errflg = 1 + errmsg = trim(message)//NEW_LINE('A')//"stop in noah-mp" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("stop in noah-mp") +#endif end if erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah ! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) if(abs(erreng) > 0.01) then write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "net solar: ",fsa +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "net longwave: ",fira +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "total sensible: ",fsh +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "canopy evap: ",fcev +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "ground evap: ",fgev +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "transpiration: ",fctr +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "total ground: ",ssoil +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "precip: ",prcp +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(a17,f10.4)') "veg fraction: ",fveg +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message)//NEW_LINE('A')//"energy budget problem in noahmp lsm" + return +#else call wrf_message(trim(message)) call wrf_error_fatal("energy budget problem in noahmp lsm") +#endif + end if if (ist == 1) then !soil @@ -1880,7 +1949,14 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in write(6,*) 'input of shdfac with lai' write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh - call wrf_error_fatal("stop in noah-mp") +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp" + return +#else + call wrf_error_fatal("stop in noah-mp") +#endif + end if ! compute a net emissivity @@ -3396,16 +3472,39 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 if((hcan-zpd) <= 0.) then write(message,*) "critical problem: hcan <= zpd" +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'i,j point=',iloc, jloc +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'hcan =',hcan +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write(message,*) 'zpd =',zpd +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message ( message ) +#endif write (message, *) 'snowh =',snowh +#ifdef CCPP + errflg = 1 + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message)//NEW_LINE('A')//"critical problem in module_sf_noahmplsm:vegeflux" + return +#else call wrf_message ( message ) call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" ) +#endif + end if ! prepare for longwave rad. @@ -4124,7 +4223,13 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in if(zlvl <= zpd) then write(*,*) 'critical problem: zlvl <= zpd; model stops' - call wrf_error_fatal("stop in noah-mp") +#ifdef CCPP + errflg = 1 + errmsg = "stop in noah-mp" + return +#else + call wrf_error_fatal("stop in noah-mp") +#endif endif tmpcm = log((zlvl-zpd) / z0m) @@ -4833,10 +4938,18 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! if (abs(err_est) > 1.) then ! w/m2 write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2' +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') & iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb +#ifdef CCPP + errmsg = trim(errmsg)//NEW_LINE('A')//trim(message) +#else call wrf_message(trim(message)) +#endif !niu stop end if @@ -5397,7 +5510,11 @@ subroutine frh2o (parameters,free,tkelv,smc,sh2o) ! ---------------------------------------------------------------------- if (kcount == 0) then write(message, '("flerchinger used in new version. iterations=", i6)') nlog +#ifdef CCPP + errmsg = trim(message) +#else call wrf_message(trim(message)) +#endif fk = ( ( (hfus / (grav * ( - parameters%psisat)))* & ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax if (fk < 0.02) fk = 0.02 diff --git a/physics/module_wrf_utl.f90 b/physics/module_wrf_utl.f90 deleted file mode 100755 index 29f8bb9e1..000000000 --- a/physics/module_wrf_utl.f90 +++ /dev/null @@ -1,50 +0,0 @@ -module module_wrf_utl - implicit none -contains - -subroutine wrf_error_fatal(string) - implicit none - character(len=*), intent(in) :: string - print*, string - stop -end subroutine wrf_error_fatal - -subroutine wrf_message(msg) - implicit none - character(len=*), intent(in) :: msg - write(*,'(A)') msg -end subroutine wrf_message - -logical function wrf_dm_on_monitor() result (return_value) - implicit none - return_value = .TRUE. -end function wrf_dm_on_monitor - -subroutine wrf_dm_bcast_real(rval, ival) - implicit none - real, intent(in) :: rval - integer, intent(in) :: ival -end subroutine wrf_dm_bcast_real - -subroutine wrf_dm_bcast_integer(ival1, ival2) - implicit none - real, intent(in) :: ival1 - integer, intent(in) :: ival2 -end subroutine wrf_dm_bcast_integer - -subroutine wrf_dm_bcast_string(sval, ival) - implicit none - character(len=*), intent(in) :: sval - integer, intent(in) :: ival -end subroutine wrf_dm_bcast_string - -subroutine wrf_debug( level , str ) - implicit none - character*(*) str - integer , intent (in) :: level - call wrf_message( str ) - return -end subroutine wrf_debug - -end module module_wrf_utl - diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 1406ec366..c5654dd44 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -628,8 +628,15 @@ subroutine noahmpdrv_run & & fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : & trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : albedo is surface albedo & qsnbot ,ponding ,ponding1,ponding2,t2mb ,q2b , & ! out : +#ifdef CCPP + & emissi ,fpice ,ch2b ,esnow, errmsg, errflg ) +#else & emissi ,fpice ,ch2b ,esnow ) +#endif +#ifdef CCPP + if (errflg /= 0) return +#endif ! ! in/out and outs ! @@ -710,8 +717,15 @@ subroutine noahmpdrv_run & & shg , shc , shb , evg , evb , ghv ,&! out : & ghb , irg , irc , irb , tr , evc ,& ! out : & chleaf , chuc , chv2 , chb2 , fpice , pahv ,& ! out - & pahg , pahb , pah , esnow ) - +#ifdef CCPP + & pahg , pahb , pah , esnow, errmsg, errflg ) +#else + & pahg , pahb , pah , esnow ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif eta = fcev + fgev + fctr ! the flux w/m2 From 10985004bc192894cd2397f1e9947fb0051e06fa Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 23 Aug 2019 21:58:10 -0600 Subject: [PATCH 08/36] pass errmsg and errflg down call chain --- physics/module_sf_noahmp_glacier.f90 | 91 ++++++++++++++--- physics/module_sf_noahmplsm.f90 | 147 +++++++++++++++++++++++++-- 2 files changed, 213 insertions(+), 25 deletions(-) diff --git a/physics/module_sf_noahmp_glacier.f90 b/physics/module_sf_noahmp_glacier.f90 index 35bad73d9..ced43ae5c 100755 --- a/physics/module_sf_noahmp_glacier.f90 +++ b/physics/module_sf_noahmp_glacier.f90 @@ -294,10 +294,18 @@ subroutine noahmp_glacier (& tbot ,zbot ,zsnso ,dzsnso , & !in tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout +#ifdef CCPP + tauss ,qsfc ,errmsg ,errflg , & !inout +#else tauss ,qsfc , & !inout +#endif imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out - sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out - trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + +#ifdef CCPP + if (errflg /= 0) return +#endif sice = max(0.0, smc - sh2o) sneqvo = sneqv @@ -324,7 +332,15 @@ subroutine noahmp_glacier (& call error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & fsh ,fgev ,ssoil ,sag ,prcp ,edir , & - runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#ifdef CCPP + runsrf ,runsub ,sneqv ,dt ,beg_wb, errmsg, errflg ) +#else + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then snowh = 0.0 @@ -399,7 +415,11 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i tbot ,zbot ,zsnso ,dzsnso , & !in tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout smc ,snice ,snliq ,albold ,cm ,ch , & !inout +#ifdef CCPP + tauss ,qsfc ,errmsg, errflg, & !inout +#else tauss ,qsfc , & !inout +#endif imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out @@ -449,6 +469,11 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i real , intent(inout) :: ch !sensible heat exchange coefficient real , intent(inout) :: tauss !snow aging factor real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! outputs integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] @@ -531,11 +556,15 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !i call glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0mg , & !in zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in - ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in - eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in - cm ,ch ,tg ,qsfc , & !inout - fira ,fsh ,fgev ,ssoil , & !out - t2m ,q2e ,ch2b) !out + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in +#ifdef CCPP + cm ,ch ,tg ,qsfc ,errmsg ,errflg , & !inout +#else + cm ,ch ,tg ,qsfc , & !inout +#endif + fira ,fsh ,fgev ,ssoil , & !out + t2m ,q2e ,ch2b) !out !energy balance at surface: sag=(irb+shb+evb+ghb) @@ -952,9 +981,13 @@ end subroutine snowalb_class_glacier ! ================================================================================================== subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0m , & !in zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in - ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in - eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in +#ifdef CCPP + cm ,ch ,tgb ,qsfc ,errmsg ,errflg , & !inout +#else cm ,ch ,tgb ,qsfc , & !inout +#endif irb ,shb ,evb ,ghb , & !out t2mb ,q2b ,ehb2) !out @@ -1001,7 +1034,12 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z real, intent(inout) :: ch !sensible heat exchange coefficient real, intent(inout) :: tgb !ground temperature (k) real, intent(inout) :: qsfc !mixing ratio at lowest model layer - + +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! output ! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] @@ -1073,9 +1111,16 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg, errflg, & !inout +#else + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif & fv ,cm ,ch ,ch2) !out +#ifdef CCPP + if (errflg /= 0) return +#endif ramb = max(1.,1./(cm*ur)) rahb = max(1.,1./(ch*ur)) rawb = rahb @@ -1212,7 +1257,11 @@ end subroutine esat subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in - & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg , & !inout +#else + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif & fv ,cm ,ch ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat @@ -1240,6 +1289,11 @@ subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! outputs real, intent(out) :: fv !friction velocity (m/s) real, intent(out) :: cm !drag coefficient for momentum @@ -2906,7 +2960,11 @@ end subroutine snowh2o_glacier ! ================================================================================================== subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & fsh ,fgev ,ssoil ,sag ,prcp ,edir , & - runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#ifdef CCPP + runsrf ,runsub ,sneqv ,dt ,beg_wb, errmsg, errflg ) +#else + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +#endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance ! -------------------------------------------------------------------------------------------------- @@ -2932,6 +2990,11 @@ subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & real , intent(in) :: dt !time step [sec] real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif + real :: end_wb !water storage at end of a timestep [mm] real :: errwat !error in water balance [mm/timestep] real :: erreng !error in surface energy balance [w/m2] diff --git a/physics/module_sf_noahmplsm.f90 b/physics/module_sf_noahmplsm.f90 index 791988a9a..4f1f7dbad 100755 --- a/physics/module_sf_noahmplsm.f90 +++ b/physics/module_sf_noahmplsm.f90 @@ -645,7 +645,7 @@ subroutine noahmp_sflx (parameters, & elai ,esai ,fwet ,foln , & !in fveg ,pahv ,pahg ,pahb , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in - z0wrf , & + z0wrf , & imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out @@ -654,16 +654,22 @@ subroutine noahmp_sflx (parameters, & tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout +#ifdef CCPP + tauss ,errmsg ,errflg , & !inout +#else tauss , & !inout +#endif !jref:start qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out emissi ,pah , & - shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end - +#ifdef CCPP + if (errflg /= 0) return +#endif sice(:) = max(0.0, smc(:) - sh2o(:)) sneqvo = sneqv @@ -709,7 +715,15 @@ subroutine noahmp_sflx (parameters, & etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in nsnow ,ist ,errwat ,iloc , jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & +#ifdef CCPP + pahv ,pahg ,pahb ,errmsg, errflg) !in ( except errwat [out] and errmsg, errflg [inout] ) +#else pahv ,pahg ,pahb ) !in ( except errwat, which is out ) +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif ! urban - jref qfx = etran + ecan + edir @@ -1209,7 +1223,11 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & etran ,edir ,runsrf ,runsub ,dt ,nsoil , & nsnow ,ist ,errwat, iloc ,jloc ,fveg , & sav ,sag ,fsrv ,fsrg ,zwt ,pah , & +#ifdef CCPP + pahv ,pahg ,pahb ,errmsg, errflg) +#else pahv ,pahg ,pahb ) +#endif ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance ! -------------------------------------------------------------------------------------------------- @@ -1258,6 +1276,11 @@ subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & real, intent(in) :: pahg !precipitation advected heat - total (w/m2) real, intent(in) :: pahb !precipitation advected heat - total (w/m2) +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif + integer :: iz !do-loop index real :: end_wb !water storage at end of a timestep [mm] !kwm real :: errwat !error in water balance [mm/timestep] @@ -1404,7 +1427,11 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tv ,tg ,stc ,snowh ,eah ,tah , & !inout sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout +#ifdef CCPP + tauss ,errmsg ,errflg, & !inout +#else tauss , & !inout +#endif !jref:start qc ,qsfc ,psfc , & !in t2mv ,t2mb ,fsrv , & @@ -1568,6 +1595,10 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in real , intent(inout) :: cm !momentum drag coefficient real , intent(inout) :: ch !sensible heat exchange coefficient real , intent(inout) :: q1 +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! real :: q2e real, intent(out) :: emissi real, intent(out) :: pah !precipitation advected heat - total (w/m2) @@ -1869,14 +1900,21 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in eah ,tah ,tv ,tgv ,cmv , & !inout +#ifdef CCPP + chv ,dx ,dz8w ,errmsg ,errflg , & !inout +#else chv ,dx ,dz8w , & !inout +#endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,ghv , & !out t2mv ,psnsun ,psnsha , & !out !jref:start qc ,qsfc ,psfc , & !in q2v ,chv2, chleaf, chuc) !inout -!jref:end +!jref:end +#ifdef CCPP + if (errflg /= 0) return +#endif end if tgb = tg @@ -1888,14 +1926,20 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in emg ,stc ,df ,rsurf ,latheag , & !in gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in +#ifdef CCPP + tgb ,cmb ,chb ,errmsg ,errflg , & !inout +#else tgb ,cmb ,chb , & !inout +#endif tauxb ,tauyb ,irb ,shb ,evb , & !out ghb ,t2mb ,dx ,dz8w ,vegtyp , & !out !jref:start qc ,qsfc ,psfc , & !in sfcprs ,q2b, chb2) !in -!jref:end - +!jref:end +#ifdef CCPP + if (errflg /= 0) return +#endif !energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg !energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg !energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg @@ -1981,7 +2025,15 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in tbot ,zsnso ,ssoil ,df ,hcpct , & !in sag ,dt ,snowh ,dzsnso , & !in tg ,iloc ,jloc , & !in +#ifdef CCPP + stc ,errmsg ,errflg ) !inout +#else stc ) !inout +#endif + +#ifdef CCPP + if (errflg /= 0) return +#endif ! adjusting snow surface temperature if(opt_stc == 2) then @@ -2003,9 +2055,15 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in dzsnso ,hcpct ,ist ,iloc ,jloc , & !in stc ,snice ,snliq ,sneqv ,snowh , & !inout +#ifdef CCPP + smc ,sh2o ,errmsg ,errflg , & !inout +#else smc ,sh2o , & !inout +#endif qmelt ,imelt ,ponding ) !out - +#ifdef CCPP + if (errflg /= 0) return +#endif end subroutine energy @@ -3209,7 +3267,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & foln ,co2air ,o2air ,btran ,sfcprs , & !in rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in eah ,tah ,tv ,tg ,cm , & !inout - ch ,dx ,dz8w , & ! +#ifdef CCPP + ch ,dx ,dz8w ,errmsg ,errflg , & !inout +#else + ch ,dx ,dz8w , & !inout +#endif tauxv ,tauyv ,irg ,irc ,shg , & !out shc ,evg ,evc ,tr ,gh , & !out t2mv ,psnsun ,psnsha , & !out @@ -3303,6 +3365,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & real, intent(inout) :: cm !momentum drag coefficient real, intent(inout) :: ch !sensible heat exchange coefficient +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif + ! output ! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 real, intent(out) :: tauxv !wind stress: e-w (n/m2) @@ -3528,8 +3595,15 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in - moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#ifdef CCPP + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout +#else + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif cm ,ch ,fv ,ch2 ) !out +#ifdef CCPP + if (errflg /= 0) return +#endif endif if(opt_sfc == 2) then @@ -3755,7 +3829,11 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in emg ,stc ,df ,rsurf ,lathea , & !in gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in +#ifdef CCPP + tgb ,cm ,ch ,errmsg ,errflg , & !inout +#else tgb ,cm ,ch , & !inout +#endif tauxb ,tauyb ,irb ,shb ,evb , & !out ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out qc ,qsfc ,psfc , & !in @@ -3818,6 +3896,10 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & real, intent(inout) :: tgb !ground temperature (k) real, intent(inout) :: cm !momentum drag coefficient real, intent(inout) :: ch !sensible heat exchange coefficient +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! output ! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 @@ -3937,8 +4019,15 @@ subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in zlvl ,zpd ,z0m ,z0h ,ur , & !in mpe ,iloc ,jloc , & !in - moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#ifdef CCPP + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 ,errmsg ,errflg ,& !inout +#else + moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout +#endif cm ,ch ,fv ,ch2 ) !out +#ifdef CCPP + if (errflg /= 0) return +#endif endif if(opt_sfc == 2) then @@ -4160,7 +4249,11 @@ end subroutine ragrb subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in & zlvl ,zpd ,z0m ,z0h ,ur , & !in & mpe ,iloc ,jloc , & !in +#ifdef CCPP + & moz ,mozsgn ,fm ,fh ,fm2,fh2,errmsg,errflg, & !inout +#else & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout +#endif & cm ,ch ,fv ,ch2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient cm for momentum and ch for heat @@ -4191,6 +4284,10 @@ subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif ! outputs @@ -4834,7 +4931,11 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! tbot ,zsnso ,ssoil ,df ,hcpct , & !in sag ,dt ,snowh ,dzsnso , & !in tg ,iloc ,jloc , & !in +#ifdef CCPP + stc ,errmsg ,errflg) !inout +#else stc ) !inout +#endif ! -------------------------------------------------------------------------------------------------- ! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures ! during melting season may exceed melting point (tfrz) but later in phasechange @@ -4867,6 +4968,10 @@ subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & ! !input and output real, dimension(-nsnow+1:nsoil), intent(inout) :: stc +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif !local @@ -5182,7 +5287,11 @@ end subroutine rosr12 subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in dzsnso ,hcpct ,ist ,iloc ,jloc , & !in stc ,snice ,snliq ,sneqv ,snowh , & !inout +#ifdef CCPP + smc ,sh2o ,errmsg ,errflg , & !inout +#else smc ,sh2o , & !inout +#endif qmelt ,imelt ,ponding ) !out ! ---------------------------------------------------------------------- ! melting/freezing of snow water and soil water @@ -5217,6 +5326,10 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] +#ifdef CCPP + character(len=*) , intent(inout) :: errmsg + integer , intent(inout) :: errflg +#endif ! local @@ -5275,7 +5388,12 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , end if end if if (opt_frz == 2) then +#ifdef CCPP + call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j),errmsg,errflg) + if (errflg /=0) return +#else call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j)) +#endif supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) end if enddo @@ -5389,8 +5507,11 @@ subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , end subroutine phasechange !== begin frh2o ==================================================================================== - +#ifdef CCPP + subroutine frh2o (parameters,free,tkelv,smc,sh2o,errmsg,errflg) +#else subroutine frh2o (parameters,free,tkelv,smc,sh2o) +#endif ! ---------------------------------------------------------------------- ! subroutine frh2o @@ -5423,6 +5544,10 @@ subroutine frh2o (parameters,free,tkelv,smc,sh2o) type (noahmp_parameters), intent(in) :: parameters real, intent(in) :: sh2o,smc,tkelv real, intent(out) :: free +#ifdef CCPP + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg +#endif real :: bx,denom,df,dswl,fk,swl,swlk integer :: nlog,kcount ! parameter(ck = 0.0) From dab6e6d5305f0b2574d68489cca40f5ba44e80bd Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Mon, 26 Aug 2019 13:30:30 -0600 Subject: [PATCH 09/36] move NoahMP calculation of julian day and year length to GFS_time_vary_pre_run; update GFS_time_vary_pre_run.fv3.F90 to new metadata and remove DDT dependency --- physics/GFS_time_vary_pre.fv3.F90 | 135 +++++++++----- physics/GFS_time_vary_pre.fv3.meta | 271 +++++++++++++++++++++++++++++ physics/dcyc2.f | 2 +- physics/noahmp_pre.F90 | 72 -------- physics/noahmp_pre.meta | 45 ----- physics/sfc_nst.f | 2 +- 6 files changed, 364 insertions(+), 163 deletions(-) create mode 100644 physics/GFS_time_vary_pre.fv3.meta delete mode 100644 physics/noahmp_pre.F90 delete mode 100644 physics/noahmp_pre.meta diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 4fecabad5..6912a8af3 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -16,10 +16,7 @@ module GFS_time_vary_pre contains !> \section arg_table_GFS_time_vary_pre_init Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_init.html !! subroutine GFS_time_vary_pre_init (errmsg, errflg) @@ -43,10 +40,7 @@ end subroutine GFS_time_vary_pre_init !> \section arg_table_GFS_time_vary_pre_finalize Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_finalize.html !! subroutine GFS_time_vary_pre_finalize(errmsg, errflg) @@ -69,26 +63,40 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|--------------------------------------------------------|-------------------------------------------------------------------------|----------|------|-----------------------|-----------|--------|----------| -!! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude GFS_time_vary_pre_run.html !! - subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) + subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & + julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type implicit none - - type(GFS_control_type), intent(inout) :: Model + + integer, intent(in) :: idate(4) + integer, intent(in) :: jdat(1:8), idat(1:8) + integer, intent(in) :: lsm, lsm_noahmp, & + nsswr, nslwr, me, & + master, nscyc + logical, intent(in) :: debug + real(kind=kind_phys), intent(in) :: dtp + + integer, intent(out) :: kdt, yearlen, ipt + logical, intent(out) :: lprnt, lssav, lsswr, & + lslwr + real(kind=kind_phys), intent(out) :: sec, phour, zhour, & + fhour, julian, solhr + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd ! Initialize CCPP error handling variables errmsg = '' @@ -96,44 +104,83 @@ subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) ! Check initialization status if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called & + &before GFS_time_vary_pre_init" errflg = 1 return end if - !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- jdat is being updated directly inside of FV3GFS_cap.F90 !--- update calendars and triggers rinc(1:5) = 0 - call w3difdat(Model%jdat,Model%idat,4,rinc) - Model%sec = rinc(4) - Model%phour = Model%sec/con_hr + call w3difdat(jdat,idat,4,rinc) + sec = rinc(4) + phour = sec/con_hr !--- set current bucket hour - Model%zhour = Model%phour - Model%fhour = (Model%sec + Model%dtp)/con_hr - Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) - - Model%ipt = 1 - Model%lprnt = .false. - Model%lssav = .true. + zhour = phour + fhour = (sec + dtp)/con_hr + kdt = nint((sec + dtp)/dtp) + + if(lsm == lsm_noahmp) then + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + endif + + ipt = 1 + lprnt = .false. + lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) - - if ((Model%debug) .and. (Model%me == Model%master)) then - print *,' sec ', Model%sec - print *,' kdt ', Model%kdt - print *,' nsswr ', Model%nsswr - print *,' nslwr ', Model%nslwr - print *,' nscyc ', Model%nscyc - print *,' lsswr ', Model%lsswr - print *,' lslwr ', Model%lslwr - print *,' fhour ', Model%fhour - print *,' phour ', Model%phour - print *,' solhr ', Model%solhr + solhr = mod(phour+idate(1),con_24) + + if ((debug) .and. (me == master)) then + print *,' sec ', sec + print *,' kdt ', kdt + print *,' nsswr ', nsswr + print *,' nslwr ', nslwr + print *,' nscyc ', nscyc + print *,' lsswr ', lsswr + print *,' lslwr ', lslwr + print *,' fhour ', fhour + print *,' phour ', phour + print *,' solhr ', solhr endif end subroutine GFS_time_vary_pre_run diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta new file mode 100644 index 000000000..3dc91952e --- /dev/null +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -0,0 +1,271 @@ +[ccpp-arg-table] + name = GFS_time_vary_pre_init + 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 = GFS_time_vary_pre_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 = GFS_time_vary_pre_run + type = scheme +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[idat] + standard_name = date_and_time_at_model_initialization + long_name = initialization date and time + units = none + dimensions = (8) + 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 +[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 + units = + dimensions = () + type = integer + intent = in + optional = F +[nslwr] + standard_name = number_of_timesteps_between_longwave_radiation_calls + long_name = number of timesteps between longwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[debug] + standard_name = flag_debug + long_name = control flag for debug + 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 +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[nscyc] + standard_name = number_of_timesteps_between_surface_cycling_calls + long_name = number of timesteps between surface cycling calls + units = + dimensions = () + type = integer + intent = in + optional = F +[sec] + standard_name = seconds_elapsed_since_model_initialization + long_name = seconds elapsed since model initialization + units = s + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[phour] + standard_name = forecast_time_at_previous_timestep + long_name = forecast time at the previous timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[zhour] + standard_name = time_since_diagnostics_zeroed + long_name = time since diagnostics variables have been zeroed + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = out + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = out + optional = F +[ipt] + standard_name = index_for_diagnostic_printout + long_name = horizontal index for point used for diagnostic printout + units = + dimensions = () + type = integer + intent = out + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lslwr] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[solhr] + standard_name = forecast_hour_of_the_day + long_name = time in hours after 00z at the current timestep + units = h + dimensions = () + 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/dcyc2.f b/physics/dcyc2.f index 5844e7371..ac6117e24 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -162,7 +162,7 @@ end subroutine dcyc2t3_finalize !> \section arg_table_dcyc2t3_run Argument Table !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |----------------|------------------------------------------------------------------------------------------------|------------------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | solhr | forecast_hour | forecast time in 24-hour form | h | 0 | real | kind_phys | in | F | +!! | solhr | forecast_hour_of_the_day | time in hours after 00z at the current timestep | h | 0 | real | kind_phys | in | F | !! | slag | equation_of_time | equation of time | radians | 0 | real | kind_phys | in | F | !! | sdec | sine_of_solar_declination_angle | sine of solar declination angle | none | 0 | real | kind_phys | in | F | !! | cdec | cosine_of_solar_declination_angle | cosine of solar declination angle | none | 0 | real | kind_phys | in | F | diff --git a/physics/noahmp_pre.F90 b/physics/noahmp_pre.F90 deleted file mode 100644 index 13d432209..000000000 --- a/physics/noahmp_pre.F90 +++ /dev/null @@ -1,72 +0,0 @@ -!> \file noahmp_pre.F90 -!! This file contains subroutines that prepare data for the NoahMP land surface model scheme -!! as part of the GFS physics suite. - module noahmp_pre - - implicit none - - contains - - subroutine noahmp_pre_init() - end subroutine noahmp_pre_init - - subroutine noahmp_pre_finalize() - end subroutine noahmp_pre_finalize - -!> \section arg_table_noahmp_pre_run Argument Table -!! \htmlinclude noahmp_pre_run.html -!! - subroutine noahmp_pre_run (jdat, julian, yearlen, errmsg, errflg) - - use machine, only : kind_phys - implicit none - - integer, intent(in) :: jdat(1:8) - - real(kind=kind_phys), intent(out) :: julian - integer , intent(out) :: yearlen - - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - integer :: iw3jdn - integer :: jd0, jd1 - real :: fjd - - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Julian day calculation (fcst day of the year) - ! we need yearln and julian to - ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 - ! jdat is changing - ! - - jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) - jd0 = iw3jdn(jdat(1),1,1) - fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 - - julian = float(jd1-jd0) + fjd - - ! - ! Year length - ! - ! what if the integration goes from one year to another? - ! iyr or jyr ? from 365 to 366 or from 366 to 365 - ! - ! is this against model's noleap yr assumption? - if (mod(jdat(1),4) == 0) then - yearlen = 366 - if (mod(jdat(1),100) == 0) then - yearlen = 365 - if (mod(jdat(1),400) == 0) then - yearlen = 366 - endif - endif - endif - - end subroutine noahmp_pre_run - - end module noahmp_pre \ No newline at end of file diff --git a/physics/noahmp_pre.meta b/physics/noahmp_pre.meta deleted file mode 100644 index a76fb1965..000000000 --- a/physics/noahmp_pre.meta +++ /dev/null @@ -1,45 +0,0 @@ -[ccpp-arg-table] - name = noahmp_pre_run - type = scheme -[jdat] - standard_name = forecast_date_and_time - long_name = current forecast date and time - units = none - dimensions = (8) - type = integer - intent = in - optional = F -[julian] - standard_name = julian_day - long_name = julian day - units = days - dimensions = () - type = real - kind = kind_phys - intent = out - optional = F -[yearlen] - standard_name = number_of_days_in_year - long_name = number of days in a year - units = days - dimensions = () - type = integer - 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/sfc_nst.f b/physics/sfc_nst.f index 086eb54f2..0f2f1ac0e 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -59,7 +59,7 @@ end subroutine sfc_nst_finalize !! | rain | nonnegative_lwe_thickness_of_precipitation_amount_on_dynamics_timestep_over_ocean | total precipitation amount in each time step over ocean | m | 1 | real | kind_phys | in | F | !! | timestep | time_step_for_dynamics | timestep interval | s | 0 | real | kind_phys | in | F | !! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | solhr | forecast_hour | fcst hour at the end of prev time step | h | 0 | real | kind_phys | in | F | +!! | solhr | forecast_hour_of_the_day | time in hours after 00z at the current timestep | h | 0 | real | kind_phys | in | F | !! | xcosz | instantaneous_cosine_of_zenith_angle | cosine of solar zenith angle | none | 1 | real | kind_phys | in | F | !! | ddvel | surface_wind_enhancement_due_to_convection | wind enhancement due to convection | m s-1 | 1 | real | kind_phys | in | F | !! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | From 869e874e1196123b6647f51d17337f0d1f819275 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 27 Aug 2019 01:12:19 +0000 Subject: [PATCH 10/36] add MYJ surface layer scheme and MYJ PBL scheme to CCPP --- physics/module_BL_MYJPBL.F90 | 2183 +++++++++++++++++++++++++++++ physics/module_MYJPBL_wrapper.F90 | 856 +++++++++++ physics/module_MYJSFC_wrapper.F90 | 554 ++++++++ physics/module_SF_JSFC.F90 | 1319 +++++++++++++++++ 4 files changed, 4912 insertions(+) create mode 100755 physics/module_BL_MYJPBL.F90 create mode 100644 physics/module_MYJPBL_wrapper.F90 create mode 100644 physics/module_MYJSFC_wrapper.F90 create mode 100755 physics/module_SF_JSFC.F90 diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 new file mode 100755 index 000000000..6f455221b --- /dev/null +++ b/physics/module_BL_MYJPBL.F90 @@ -0,0 +1,2183 @@ +!----------------------------------------------------------------------- +! + MODULE MODULE_BL_MYJPBL +! +!----------------------------------------------------------------------- +! +!*** THE MYJ PBL SCHEME +! +!----------------------------------------------------------------------- +! +! USE MODULE_INCLUDE +! +! USE MODULE_CONSTANTS,ONLY : A2,A3,A4,CP,ELIV,ELWV,ELIWV & +! ,EP_1,EPSQ & +! ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & +! ,STBOLT,CAPPA + +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! integer,parameter :: isingle=selected_int_kind(r=9) +! integer,parameter :: idouble=selected_int_kind(r=18) +! integer,parameter :: single=selected_real_kind(p=6,r=37) +! integer,parameter :: double=selected_real_kind(p=13,r=200) + +! integer,parameter:: & +! klog=4 & +! ,kint=isingle & +! ,kdin=idouble & +! ,kfpt=single & +! ,kdbl=double + +! real (kind=kfpt),parameter :: r4_in=x'ffbfffff' +! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' +! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) + + integer,parameter:: & + klog=4 & ! logical variables + ,kint=4 & ! integer variables + ,kfpt=4 & ! floating point variables + ,kdbl=8 ! double precision + + REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & + ,ELIV=2.850e6,ELWV=2.501e6,R_V=461.6 & +! ,EPSQ=1.e-12,EPSQ2=0.02,G=9.8060226 & + ,EPSQ=1.e-12,G=9.8060226 & + ,PQ0=379.90516,R_D=287.04,EP_1=R_V/R_D-1. & + ,P608=R_V/R_D-1.,PI=3.141592653589793 & + ,RHOWATER=1000.,STBOLT=5.67051E-8,CAPPA=R_D/CP + REAL(kind=kfpt),PARAMETER :: eliwv=2.683e6 +! + REAL(kind=kfpt),PARAMETER :: CONW=1./G,CONT=CP/G,CONQ=ELWV/G + +!----------------------------------------------------------------------- +! + PRIVATE +! + PUBLIC:: MYJPBL_INIT, MYJPBL +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!*** FOR MYJ TURBULENCE +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + ELEVFC=0.6 +! + REAL(KIND=KFPT),PARAMETER:: & + VKARMAN=0.4 & +! + ,XLS=ELIV,XLV=ELWV & + ,RLIVWV=XLS/XLV,ELOCP=2.72E6/CP & +! + ,EPS1=1.E-12,EPS2=0. & + ,EPSRU=1.E-7,EPSRS=1.E-7 & + ,EPSTRB=1.E-24 & + ,FH=1.10 & +! + ,ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & +! ,ELFC=0.5,GAM1=0.2222222222222222222 & +! ,ELFC=0.23*0.25,GAM1=0.2222222222222222222 & + ,ELFC=1.,GAM1=0.2222222222222222222 & +! + ,A1=0.659888514560862645 & + ,A2X=0.6574209922667784586 & + ,B1=11.87799326209552761 & + ,B2=7.226971804046074028 & + ,C1=0.000830955950095854396 & + ,ELZ0=0.,ESQ=5.0 & +! + ,SEAFC=0.98,PQ0SEA=PQ0*SEAFC & +! + ,BTG=BETA*G & + ,ESQHF=0.5*5.0 & + ,RB1=1./B1 +! + REAL(KIND=KFPT),PARAMETER:: & + ADNH= 9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,ADNM=18.*A1*A1*A2X*(B2-3.*A2X)*BTG & + ,ANMH=-9.*A1*A2X*A2X*BTG*BTG & + ,ANMM=-3.*A1*A2X*(3.*A2X+3.*B2*C1+18.*A1*C1-B2)*BTG & + ,BDNH= 3.*A2X*(7.*A1+B2)*BTG & + ,BDNM= 6.*A1*A1 & + ,BEQH= A2X*B1*BTG+3.*A2X*(7.*A1+B2)*BTG & + ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & + ,BNMH=-A2X*BTG & + ,BNMM=A1*(1.-3.*C1) & + ,BSHH=9.*A1*A2X*A2X*BTG & + ,BSHM=18.*A1*A1*A2X*C1 & + ,BSMH=-3.*A1*A2X*(3.*A2X+3.*B2*C1+12.*A1*C1-B2)*BTG & + ,CESH=A2X & + ,CESM=A1*(1.-3.*C1) & + ,CNV=EP_1*G/BTG +! +!----------------------------------------------------------------------- +!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + AEQH=9.*A1*A2X*A2X*B1*BTG*BTG & + +9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,AEQM=3.*A1*A2X*B1*(3.*A2X+3.*B2*C1+18.*A1*C1-B2) & + *BTG+18.*A1*A1*A2X*(B2-3.*A2X)*BTG +! +!----------------------------------------------------------------------- +!*** FORBIDDEN TURBULENCE AREA +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + REQU=-AEQH/AEQM & + ,EPSGH=1.E-9,EPSGM=REQU*EPSGH +! +!----------------------------------------------------------------------- +!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + UBRYL=(18.*REQU*A1*A1*A2X*B2*C1*BTG & + +9.*A1*A2X*A2X*B2*BTG*BTG) & + /(REQU*ADNM+ADNH) & + ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY +! + REAL(KIND=KFPT),PARAMETER:: & + AUBH=27.*A1*A2X*A2X*B2*BTG*BTG-ADNH*UBRY3 & + ,AUBM=54.*A1*A1*A2X*B2*C1*BTG -ADNM*UBRY3 & + ,BUBH=(9.*A1*A2X+3.*A2X*B2)*BTG-BDNH*UBRY3 & + ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & + ,CUBR=1. - UBRY3 & + ,RCUBR=1./CUBR +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!---LOOK-UP TABLES------------------------------------------------------ +INTEGER(KIND=KINT),PARAMETER:: & + ITBL=401 & ! CONVECTION TABLES, DIMENSION 1 +,JTBL=1201 & ! CONVECTION TABLES, DIMENSION 2 +,KERFM=301 & ! SIZE OF ERF HALF TABLE +,KERFM2=KERFM-2 ! INTERNAL POINTS OF ERF HALF TABLE + +REAL(KIND=KFPT),PARAMETER:: & + PL=2500. & ! LOWER BOUND OF PRESSURE RANGE +,PH=105000. & ! UPPER BOUND OF PRESSURE RANGE +,THL=210. & ! LOWER BOUND OF POTENTIAL TEMPERATURE RANGE +,THH=365. & ! UPPER BOUND OF POTENTIAL TEMPERATURE RANGE +,XEMIN=0. & ! LOWER BOUND OF ERF HALF TABLE +,XEMAX=3. ! UPPER BOUND OF ERF HALF TABLE + +REAL(KIND=KFPT),PRIVATE,SAVE:: & + RDP & ! SCALING FACTOR FOR PRESSURE +,RDQ & ! SCALING FACTOR FOR HUMIDITY +,RDTH & ! SCALING FACTOR FOR POTENTIAL TEMPERATURE +,RDTHE & ! SCALING FACTOR FOR EQUIVALENT POT. TEMPERATURE +,RDXE ! ERF HALF TABLE SCALING FACTOR + +REAL(KIND=KFPT),DIMENSION(1:ITBL),PRIVATE,SAVE:: & + STHE & ! RANGE FOR EQUIVALENT POTENTIAL TEMPERATURE +,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE + +REAL(KIND=KFPT),DIMENSION(1:JTBL),PRIVATE,SAVE:: & + QS0 & ! BASE FOR SATURATION SPECIFIC HUMIDITY +,SQS ! RANGE FOR SATURATION SPECIFIC HUMIDITY + +REAL(KIND=KFPT),DIMENSION(1:KERFM),PRIVATE,SAVE:: & + HERFF ! HALF ERF TABLE + +REAL(KIND=KFPT),DIMENSION(1:ITBL,1:JTBL),PRIVATE,SAVE:: & + PTBL ! SATURATION PRESSURE TABLE + +REAL(KIND=KFPT),DIMENSION(1:JTBL,1:ITBL),PRIVATE,SAVE:: & + TTBL ! TEMPERATURE TABLE +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + CONTAINS +! +!----------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!----------------------------------------------------------------------- +! +! REFERENCES: JANJIC (2001), NCEP OFFICE NOTE 437 +! +! ABSTRACT: +! MYJ UPDATES THE TURBULENT KINETIC ENERGY WITH THE PRODUCTION/ +! DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM +! (USING AN IMPLICIT FORMULATION) FROM MELLOR-YAMADA +! LEVEL 2.5 AS EXTENDED BY JANJIC. EXCHANGE COEFFICIENTS FOR +! THE SURFACE LAYER ARE COMPUTED FROM THE MONIN-OBUKHOV THEORY. +! THE TURBULENT VERTICAL EXCHANGE IS THEN EXECUTED. +! +!----------------------------------------------------------------------- + SUBROUTINE MYJPBL(NTSD,ME,DT_PHS,EPSL,EPSQ2,HT,STDH,DZ,DEL & + ,PMID,PINH,TH,T,EXNER,Q,CWM,U,V & + ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & + ,XLAND,SICE,SNOW & + ,Q2,EXCH_H,USTAR,Z0,EL_MYJ,PBLH,KPBL,CT & + ,AKHS,AKMS,ELFLX,MIXHT,THLM,QLM & + ,RUBLTEN,RVBLTEN,RTHBLTEN,RQBLTEN,RQCBLTEN & + ,DUSFC,DVSFC,DTSFC,DQSFC,xkzo,xkzmo,ICT & + ,IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM) + +! SUBROUTINE MYJPBL(DT,NPHS,EPSL,EPSQ2,HT,STDH,DZ & +! ,PMID,PINH,TH,T,EXNER,Q,CWM,U,V & +! ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & +! ,XLAND,SICE,SNOW & +! ,Q2,EXCH_H,USTAR,Z0,EL_MYJ,PBLH,KPBL,CT & +! ,AKHS,AKMS,ELFLX,MIXHT & +! ,RUBLTEN,RVBLTEN,RTHBLTEN,RQBLTEN,RQCBLTEN & +! ,IDS,IDE,JDS,JDE & +! ,IMS,IME,JMS,JME & +! ,ITS,ITE,JTS,JTE,LM) + +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! + logical(kind=klog),save:: & + reinit +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM +! + INTEGER,INTENT(IN) :: ICT,ME,NTSD + +! INTEGER(KIND=KINT),INTENT(IN):: & +! NPHS +! + INTEGER(KIND=KINT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + KPBL +! + REAL(KIND=KFPT),INTENT(IN):: & + DT_PHS +! DT +! + real(kind=kfpt),dimension(1:lm-1),intent(inout):: EPSL + real(kind=kfpt),dimension(1:lm),intent(in):: EPSQ2 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN):: & + HT,SICE,SNOW,STDH & + ,TSK,XLAND & + ,CHKLOWQ,ELFLX,THLM,QLM +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN):: & + DZ,EXNER,PMID,Q,CWM,U,V,T,TH,DEL,xkzo,xkzmo +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN):: & + PINH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + EL_MYJ +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + RQCBLTEN & + ,RUBLTEN,RVBLTEN & + ,RTHBLTEN,RQBLTEN +! + REAL(kind=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: & + DUSFC,DVSFC & + ,DTSFC,DQSFC +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + AKHS,AKMS +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + CT,QSFC,QZ0 & + ,THZ0,USTAR & + ,UZ0,VZ0,Z0 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT):: & + EXCH_H & + ,Q2 +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + I,IQTB,ITTB,J,K,LLOW,LMH,LMXL +! + INTEGER(KIND=KINT),DIMENSION(IMS:IME,JMS:JME):: & + LPBL +! + REAL(KIND=KFPT):: & + AKHS_DENS,AKMS_DENS,BQ,BQS00K,BQS10K & + ,DCDT,DELTAZ,DQDT,DTDIF,DTDT,DTTURBL & + ,P00K,P01K,P10K,P11K,PELEVFC,PP1,PSFC,PSP,PTOP & + ,QBT,QFC1,QLOW,QQ1,QX & + ,RDTTURBL,RG,RSQDT,RXNERS,RXNSFC & + ,SEAMASK,SQ,SQS00K,SQS10K & + ,THBT,THNEW,THOLD,TQ,TTH & + ,ULOW,VLOW,RSTDH,STDFAC,ZSF,ZSX,ZSY,ZUV +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + CWMK,PK,PSK,Q2K,QK,RHOK,RXNERK,THEK,THK,THVK,TK,UK,VK +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + AKHK,AKMK,DCOL,EL,GH,GM +! + REAL(KIND=KFPT),DIMENSION(1:LM+1):: & + ZHK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME):: & + THSK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM):: & + RXNER,THV +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM-1):: & + AKH,AKM +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1):: & + ZINT +! +!*** Begin debugging + REAL(KIND=KFPT):: ZSL_DIAG + INTEGER(KIND=KINT):: IMD,JMD,PRINT_DIAG +!*** End debugging +!----------------------------------------------------------------------- +!*********************************************************************** + data reinit/.false./ +!----------------------------------------------------------------------- +! if(reinit) then +! call MYJPBL_INIT( & +! 1,IDE,1,1,LM, & +! 1,IDE,1,1, & +! 1,IDE,1,1) +! reinit=.false. +! endif +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + STDFAC=1. +!---------------------------------------------------------------------- +! DTTURBL=DT*NPHS + DTTURBL=DT_PHS + RDTTURBL=1./DTTURBL + RSQDT=SQRT(RDTTURBL) + DTDIF=DTTURBL + RG=1./G +! + DO K=1,LM-1 + DO J=JTS,JTE + DO I=ITS,ITE + AKM(I,J,K)=0. + ENDDO + ENDDO + ENDDO +! + DO K=1,LM+1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=0. + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER + ENDDO + ENDDO +! + DO K=LM,1,-1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=ZINT(I,J,K+1)+DZ(I,J,K) + RXNER(I,J,K)=1./EXNER(I,J,K) + THV(I,J,K)=(Q(I,J,K)*0.608+(1.-CWM(I,J,K)))*TH(I,J,K) + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + EL_MYJ(I,J,LM)=0. + ENDDO + ENDDO + DO J=JTS,JTE + DO I=ITS,ITE + DUSFC(I,J)=0. + DVSFC(I,J)=0. + DTSFC(I,J)=0. + DQSFC(I,J)=0. + ENDDO + ENDDO + +! +!---------------------------------------------------------------------- +!....................................................................... +!ZJ$OMP PARALLEL DO & +!ZJ$OMP PRIVATE(J,I,LMH,PTOP,PSFC,SEAMASK,K,TK,THVK,QK,Q2K,RXNERK, & +!ZJ$OMP PK,UK,VK,Q2K,ZHK,LMXL,GM,GH,EL,AKMK,AKHK,DELTAZ), & +!ZJ$OMP SCHEDULE(DYNAMIC) +!....................................................................... +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE +! + LMH=LM +! + PTOP=PINH(I,J,1) + PSFC=PINH(I,J,LMH+1) +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=LM,1,-1 + PK(K)=PMID(I,J,K) + TK(K)=T(I,J,K) + QK(K)=Q(I,J,K) + THVK(K)=THV(I,J,K) + RXNERK(K)=RXNER(I,J,K) + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + Q2K(K)=Q2(I,J,K) +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,J,K) +! + ENDDO + ZHK(LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER +! +!*** POTENTIAL INSTABILITY +! + PELEVFC=PMID(I,J,LMH)*ELEVFC +! + DO K=LMH,1,-1 +!----------------------------------------------------------------------- + IF(K==LMH .OR. PMID(I,J,K)>PELEVFC) THEN +!---PREPARATION FOR SEARCH FOR MAX CAPE--------------------------------- + QBT=QK(K) + THBT=TH(I,J,K) + TTH=(THBT-THL)*RDTH + QQ1=TTH-AINT(TTH) + ITTB=INT(TTH)+1 +!---KEEPING INDICES WITHIN THE TABLE------------------------------------ + IF(ITTB.LT.1)THEN + ITTB=1 + QQ1=0. + ELSE IF(ITTB.GE.JTBL)THEN + ITTB=JTBL-1 + QQ1=0. + ENDIF +!---BASE AND SCALING FACTOR FOR SPEC. HUMIDITY-------------------------- + BQS00K=QS0(ITTB) + SQS00K=SQS(ITTB) + BQS10K=QS0(ITTB+1) + SQS10K=SQS(ITTB+1) +!--------------SCALING SPEC. HUMIDITY & TABLE INDEX--------------------- + BQ=(BQS10K-BQS00K)*QQ1+BQS00K + SQ=(SQS10K-SQS00K)*QQ1+SQS00K + TQ=(QBT-BQ)/SQ*RDQ + PP1=TQ-AINT(TQ) + IQTB=INT(TQ)+1 +!----------------KEEPING INDICES WITHIN THE TABLE----------------------- + IF(IQTB.LT.1)THEN + IQTB=1 + PP1=0. + ELSEIF(IQTB.GE.ITBL)THEN + IQTB=ITBL-1 + PP1=0. + ENDIF +!--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.------- + P00K=PTBL(IQTB ,ITTB ) + P10K=PTBL(IQTB+1,ITTB ) + P01K=PTBL(IQTB ,ITTB+1) + P11K=PTBL(IQTB+1,ITTB+1) +!--------------SATURATION POINT VARIABLES AT THE BOTTOM----------------- + PSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1 & + +(P00K-P10K-P01K+P11K)*PP1*QQ1 + RXNERS=(1.E5/PSP)**CAPPA + THEK(K)=THBT*EXP(ELOCP*QBT*RXNERS/THBT) + PSK (K)=PSP +!----------------------------------------------------------------------- + ELSE +!----------------------------------------------------------------------- + THEK(K)=THEK(K+1) + PSK (K)=PINH(I,J,1) +!----------------------------------------------------------------------- + ENDIF +!----------------------------------------------------------------------- + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=1 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=2 +!*** End debugging +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE MIXING LENGTH +!*** + CALL MIXLEN(LMH,RSQDT,UK,VK,THVK,THEK & + ,Q2K,EPSL,EPSQ2,ZHK,PK,PSK,RXNERK,GM,GH,EL & + ,PBLH(I,J),LPBL(I,J),LMXL,CT(I,J),MIXHT(I,J) & + ,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** SOLVE FOR THE PRODUCTION/DISSIPATION OF +!*** THE TURBULENT KINETIC ENERGY +!*** +! + CALL PRODQ2(NTSD,ME,LMH,DTTURBL,USTAR(I,J),GM,GH,EL,Q2K & + ,EPSL,EPSQ2,I,J,LM) + +! if(i.eq.4)print*,'11ql test Q2(LMH)=',Q2K(LMH),B1,USTAR(I,J) +! +!---------------------------------------------------------------------- +!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL +!---------------------------------------------------------------------- +! + KPBL(I,J)=LPBL(I,J) +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE EXCHANGE COEFFICIENTS IN THE FREE ATMOSPHERE +!*** + CALL DIFCOF(NTSD,ME,LMH,LMXL,GM,GH,EL,TK,Q2K,ZHK,AKMK,AKHK,I,J,LM & + ,PRINT_DIAG,KPBL(I,J)) +! +!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH +!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS 1 TO LM-1. COUNTING +!*** COUNTING UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS EXCH_H +!*** ARE DEFINED ON THE TOPS OF THE LAYERS 1 TO LM-1. +! + DO K=1,LM-1 + + DELTAZ=0.5*(ZHK(K)-ZHK(K+2)) + AKHK(K)=max(AKHK(K),xkzo(I,J,K)/DELTAZ) ! add minimum background diffusion + AKMK(K)=max(AKMK(K),xkzmo(I,J,K)/DELTAZ) + if((THVK(LM)-THVK(K)).GT.0.) then + AKHK(K)=max(AKHK(K),3./DELTAZ) ! add minimum background diffusion + AKMK(K)=max(AKMK(K),3./DELTAZ) + end if + AKH(I,J,K)=AKHK(K) + AKM(I,J,K)=AKMK(K) + EXCH_H(I,J,K)=AKHK(K)*DELTAZ + ENDDO +! +!---------------------------------------------------------------------- +!*** +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TURBULENT KINETIC ENERGY +!*** +! + CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK,I,J,LM) +! +!*** SAVE THE NEW Q2 AND MIXING LENGTH. +! + DO K=1,LM + Q2(I,J,K)=MAX(Q2K(K),EPSQ2(K)) + IF(K0..OR.SICE(I,J)>0.5)THEN + QFC1=QFC1*RLIVWV + ENDIF +! + IF(QFC1>0.)THEN + QLOW=QK(LM) +!ql QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 + ENDIF +! + ELSE + PSFC=PINH(I,J,LM+1) + RXNSFC=(1.E5/PSFC)**CAPPA + +!ql QSFC(I,J)=PQ0SEA/PSFC & +!ql & *EXP(A2*(THSK(I,J)-A3*RXNSFC)/(THSK(I,J)-A4*RXNSFC)) + ENDIF +! + QZ0 (I,J)=(1.-SEAMASK)*QSFC(I,J)+SEAMASK*QZ0 (I,J) +! + LMH=LM +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TEMPERATURE AND WATER VAPOR +!---------------------------------------------------------------------- +! + CALL VDIFH(DTDIF,LMH,THZ0(I,J),QZ0(I,J) & + ,AKHS_DENS,CHKLOWQ(I,J),CT(I,J) & + ,THK,QK,CWMK,AKHK,ZHK,RHOK,I,J,LM) +!---------------------------------------------------------------------- +!*** +! QL set lower bondary +! THK(LM)=THLM(I,J) +! QK(LM)=QLM(I,J) +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RTHBLTEN(I,J,K)=(THK(K)-TH(I,J,K))*RDTTURBL + RQBLTEN(I,J,K)=(QK(K)-Q(I,J,K))*RDTTURBL + RQCBLTEN(I,J,K)=(CWMK(K)-CWM(I,J,K))*RDTTURBL + DTSFC(I,J)=DTSFC(I,J)+CONT*DEL(I,J,K)*RTHBLTEN(I,J,K)*EXNER(I,J,K) + DQSFC(I,J)=DQSFC(I,J)+CONQ*DEL(I,J,K)*RQBLTEN(I,J,K) + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=0 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=0 +!*** End debugging +! + PSFC=.01*PINH(I,J,LM+1) + ZSL_DIAG=0.5*DZ(I,J,LM) +! +!*** Begin debugging +! IF(PRINT_DIAG==1)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '{TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '{TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '{TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '{TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! +! ELSEIF(PRINT_DIAG==2)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '}TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '}TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '}TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '}TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! ENDIF +!*** End debugging +! +!---------------------------------------------------------------------- +! + SEAMASK=XLAND(I,J)-1. +! + IF(SEAMASK.LT.0.5.AND.STDH(I,J).GT.1.) THEN + RSTDH=1./STDH(I,J) + ELSE + RSTDH=0. + ENDIF + ZHK(LM+1)=ZINT(I,J,LM+1) + ZSF=STDH(I,J)*STDFAC+ZHK(LM+1) +! +!---------------------------------------------------------------------- +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=1,LM-1 + AKMK(K)=AKM(I,J,K) + AKMK(K)=AKMK(K)*(RHOK(K)+RHOK(K+1))*0.5 + ENDDO +! + AKMS_DENS=AKMS(I,J)*RHOK(LM) +! + DO K=LM,1,-1 + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + ZHK(K)=ZINT(I,J,K) + ENDDO + ZHK(LM+1)=ZINT(I,J,LM+1) +! +!---------------------------------------------------------------------- +! + DO K=1,LM-1 +!jun23 IF(SEAMASK.GT.0.5) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 ZUV=(ZHK(K)+ZHK(K+1))*0.5 +!jun23 IF(ZUV.GT.ZSF) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 DCOL(K)=HERF((((ZUV-ZHK(LM+1))*RSTDH)**2)*0.5) +!jun23 ENDIF +!jun23 ENDIF +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW + DCOL(K)=0. !ZJ +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM + ENDDO +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** VELOCITY COMPONENTS +!---------------------------------------------------------------------- +! + CALL VDIFV(LMH,DTDIF,UZ0(I,J),VZ0(I,J) & + & ,AKMS_DENS,DCOL,UK,VK,AKMK,ZHK,RHOK,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RUBLTEN(I,J,K)=(UK(K)-U(I,J,K))*RDTTURBL + RVBLTEN(I,J,K)=(VK(K)-V(I,J,K))*RDTTURBL + DUSFC(I,J)=DUSFC(I,J)+CONW*DEL(I,J,K)*RUBLTEN(I,J,K) + DVSFC(I,J)=DVSFC(I,J)+CONW*DEL(I,J,K)*RVBLTEN(I,J,K) + ENDDO +! + ENDDO +!---------------------------------------------------------------------- +! + ENDDO main_integration +!JAA!ZJ$OMP END PARALLEL DO +! +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJPBL +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE MIXLEN & +!---------------------------------------------------------------------- +! ****************************************************************** +! * * +! * LEVEL 2.5 MIXING LENGTH * +! * * +! ****************************************************************** +! + (LMH,RSQDT,U,V,THV,THE,Q2,EPSL,EPSQ2,Z,P,PS,RXNER & + ,GM,GH,EL,PBLH,LPBL,LMXL,CT,MIXHT,I,J,LM) +! +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,I,J,LM +! + REAL(KIND=KFPT),INTENT(IN):: & + RSQDT +! + INTEGER(KIND=KINT),INTENT(OUT):: & + LMXL,LPBL +! + real(kind=kfpt),dimension(1:lm-1),intent(inout):: EPSL + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + P,PS,EPSQ2,RXNER,THE,THV,U,V +! P,PS,Q2,EPSQ2,RXNER,THE,THV,U,V +! + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(INOUT):: Q2 +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + EL,GH,GM +! + REAL(KIND=KFPT),INTENT(INOUT):: CT +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,LPBLM +! + REAL(KIND=KFPT):: & + ADEN,BDEN,AUBR,BUBR,BLMX,CUBRY,DTHV,DZ & + ,EL0,ELOQ2X,GHL,GML & + ,QOL2ST,QOL2UN,QDZL & + ,RDZ,SQ,SREL,SZQ,VKRMZ,WCON +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + Q1 +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + ELM,REL +! +!---------------------------------------------------------------------- +!*********************************************************************** +!--------1---------2---------3---------4---------5---------6---------7-- + CUBRY=UBRY*1.5 !*2. +!--------------FIND THE HEIGHT OF THE PBL------------------------------- + LPBL=LMH +! LPBL=LMH-1 + DO K=LMH-1,1,-1 +! EPSL(K)=1. + if((THV(LMH)-THV(K)).GT.0.) then + Q2(K)=max(Q2(K),1.0) + EPSL(K)=10. + ENDIF + ENDDO +! + DO K=LMH-1,1,-1 + if(q2(k)-epsq2(k)+epsq2(lm).le.epsq2(lm)*fh) then + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!--------------THE HEIGHT OF THE PBL------------------------------------ +! + 110 PBLH=Z(LPBL+1)-Z(LMH+1) +! +!----------------------------------------------------------------------- + DO K=1,LMH + Q1(K)=0. + ENDDO +!----------------------------------------------------------------------- + DO K=1,LMH-1 + DZ=(Z(K)-Z(K+2))*0.5 + RDZ=1./DZ + GML=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ + GM(K)=MAX(GML,EPSGM) +! + DTHV=THV(K)-THV(K+1) +!---------------------------------------------------------------------- + IF(DTHV.GT.0.) THEN + IF(THE(K+1).GT.THE(K)) THEN + IF(PS(K+1).GT.P(K)) THEN !>12KM +! + WCON=(P(K+1)-PS(K+1))/(P(K+1)-P(K)) +! + if( & + (q2(k).gt.epsq2(k)) .and. & + (q2(k)*cubry.gt.(dz*wcon*rsqdt)**2) & + ) then +! + DTHV=(THE(K)-THE(K+1))+DTHV +! + ENDIF + ENDIF + ENDIF + ENDIF +!-------------------------------------------------------------------------- +! + GHL=DTHV*RDZ + IF(ABS(GHL)<=EPSGH)GHL=EPSGH + GH(K)=GHL + ENDDO +! + CT=0. +! +!---------------------------------------------------------------------- +!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP +!---------------------------------------------------------------------- +! + LMXL=LMH +! + DO K=1,LMH-1 + GML=GM(K) + GHL=GH(K) +! + IF(GHL>=EPSGH)THEN + IF(GML/GHL<=REQU)THEN + ELM(K)=EPSL(K) + LMXL=K+1 + ELSE + AUBR=(AUBM*GML+AUBH*GHL)*GHL + BUBR= BUBM*GML+BUBH*GHL + QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR + ELOQ2X=1./MAX(EPSGH, QOL2ST) + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ELSE + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) + ELOQ2X=1./(QOL2UN+EPSRU) ! REPSR1/QOL2UN + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ENDDO +! + IF(ELM(LMH-1)==EPSL(LMH-1))LMXL=LMH +! +!---------------------------------------------------------------------- +!*** THE HEIGHT OF THE MIXED LAYER +!---------------------------------------------------------------------- +! + BLMX=Z(LMXL)-Z(LMH+1) + MIXHT=BLMX +! +!---------------------------------------------------------------------- + DO K=LPBL,LMH + Q1(K)=SQRT(Q2(K)) + ENDDO +!---------------------------------------------------------------------- + SZQ=0. + SQ =0. +! + DO K=1,LMH-1 + QDZL=(Q1(K)+Q1(K+1))*(Z(K+1)-Z(K+2)) + SZQ=(Z(K+1)+Z(K+2)-Z(LMH+1)-Z(LMH+1))*QDZL+SZQ + SQ=QDZL+SQ + ENDDO +! +!---------------------------------------------------------------------- +!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA +!---------------------------------------------------------------------- +! + EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) + EL0=MAX(EL0 ,EL0MIN) +! +!---------------------------------------------------------------------- +!*** ABOVE THE PBL TOP +!---------------------------------------------------------------------- +! + LPBLM=MAX(LPBL-1,1) +! + DO K=1,LPBLM + EL(K)=MIN((Z(K)-Z(K+2))*ELFC,ELM(K)) + REL(K)=EL(K)/ELM(K) + ENDDO +! +!---------------------------------------------------------------------- +!*** INSIDE THE PBL +!---------------------------------------------------------------------- +! + IF(LPBL=EPSGH.AND.GML/GHL<=REQU) & + & .OR.(EQOL2<=EPS2)))THEN +! & .OR.(EQOL2<=EPS2)).and.IFLAG.EQ.1)THEN +! +! if(ntsd.eq.23.and.me.eq.76.and.I.eq.32)then +! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL +! end if +!---------------------------------------------------------------------- +!*** NO TURBULENCE +!---------------------------------------------------------------------- +! + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) +! IFLAG=2 +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** TURBULENCE +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE NUMERATOR +!---------------------------------------------------------------------- +! + ANUM=(ANMM*GML+ANMH*GHL)*GHL + BNUM= BNMM*GML+BNMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE NUMERATOR OF THE LINEARIZED EQ. +!---------------------------------------------------------------------- +! + ARHS=-(ANUM*BDEN-BNUM*ADEN)*2. + BRHS=- ANUM*4. + CRHS=- BNUM*2. +! +!---------------------------------------------------------------------- +!*** INITIAL VALUE OF L/Q +!---------------------------------------------------------------------- +! + DLOQ1=EL(K)/SQRT(Q2(K)) +! +!---------------------------------------------------------------------- +!*** FIRST ITERATION FOR L/Q, RHS=0 +!---------------------------------------------------------------------- +! + ELOQ21=1./EQOL2 + ELOQ11=SQRT(ELOQ21) + ELOQ31=ELOQ21*ELOQ11 + ELOQ41=ELOQ21*ELOQ21 + ELOQ51=ELOQ21*ELOQ31 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN1=1./(ADEN*ELOQ41+BDEN*ELOQ21+CDEN) +! +!---------------------------------------------------------------------- +!*** D(RHS)/D(L/Q) +!---------------------------------------------------------------------- +! + RHSP1=(ARHS*ELOQ51+BRHS*ELOQ31+CRHS*ELOQ11)*RDEN1*RDEN1 +! +!---------------------------------------------------------------------- +!*** FIRST-GUESS SOLUTION +!---------------------------------------------------------------------- +! + ELOQ12=ELOQ11+(DLOQ1-ELOQ11)*EXP(RHSP1*DTTURBL) + ELOQ12=MAX(ELOQ12,EPS1) +! +!---------------------------------------------------------------------- +!*** SECOND ITERATION FOR L/Q +!---------------------------------------------------------------------- +! + ELOQ22=ELOQ12*ELOQ12 + ELOQ32=ELOQ22*ELOQ12 + ELOQ42=ELOQ22*ELOQ22 + ELOQ52=ELOQ22*ELOQ32 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN2=1./(ADEN*ELOQ42+BDEN*ELOQ22+CDEN) + RHS2 =-(ANUM*ELOQ42+BNUM*ELOQ22)*RDEN2+RB1 + RHSP2= (ARHS*ELOQ52+BRHS*ELOQ32+CRHS*ELOQ12)*RDEN2*RDEN2 + RHST2=RHS2/RHSP2 +! +!---------------------------------------------------------------------- +!*** CORRECTED SOLUTION +!---------------------------------------------------------------------- +! + ELOQ13=ELOQ12-RHST2+(RHST2+DLOQ1-ELOQ12)*EXP(RHSP2*DTTURBL) + ELOQ13=AMAX1(ELOQ13,EPS1) +! +!---------------------------------------------------------------------- +!*** TWO ITERATIONS IS ENOUGH IN MOST CASES ... +!---------------------------------------------------------------------- +! + ELOQN=ELOQ13 +! + IF(ELOQN>EPS1)THEN + Q2(K)=EL(K)*EL(K)/(ELOQN*ELOQN) + Q2(K)=AMAX1(Q2(K),EPSQ2(K)) + IF(Q2(K)==EPSQ2(K))THEN + EL(K)=EPSL(K) + ENDIF + ELSE + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) + ENDIF +! +!---------------------------------------------------------------------- +!*** END OF TURBULENT BRANCH +!---------------------------------------------------------------------- +! + ENDIF +!---------------------------------------------------------------------- +!*** END OF PRODUCTION/DISSIPATION LOOP +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +!*** LOWER BOUNDARY CONDITION FOR Q2 +!---------------------------------------------------------------------- +! + Q2(LMH)=AMAX1(B1**(2./3.)*USTAR*USTAR,EPSQ2(LMH)) +! if(I.eq.4)print*,'12ql test Q2(LMH)=',LMH,Q2(LMH),B1,USTAR + +!---------------------------------------------------------------------- +! + END SUBROUTINE PRODQ2 +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE DIFCOF & +! ****************************************************************** +! * * +! * LEVEL 2.5 DIFFUSION COEFFICIENTS * +! * * +! ****************************************************************** + (NTSD,ME,LMH,LMXL,GM,GH,EL,T,Q2,Z,AKM,AKH,I,J,LM,PRINT_DIAG,KPBL) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,LMXL,I,J,LM,ME,NTSD,KPBL +! + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + Q2,T +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(IN):: & + EL,GH,GM +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + AKH,AKM +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,KINV +! + REAL(KIND=KFPT):: & + ADEN,AKMIN,BDEN,BESH,BESM,CDEN,D2T,ELL,ELOQ2,ELOQ4,ELQDZ & + ,ESH,ESM,GHL,GML,Q1L,RDEN,RDZ +! +!*** Begin debugging + INTEGER(KIND=KINT),INTENT(IN):: PRINT_DIAG +! REAL(KIND=KFPT):: D2TMIN +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! + DO K=1,LMH-1 + ELL=EL(K) +! + ELOQ2=ELL*ELL/Q2(K) + ELOQ4=ELOQ2*ELOQ2 +! + GML=GM(K) + GHL=GH(K) +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SM DETERMINANT +!---------------------------------------------------------------------- +! + BESM=BSMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SH DETERMINANT +!---------------------------------------------------------------------- +! + BESH=BSHM*GML+BSHH*GHL +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN=1./(ADEN*ELOQ4+BDEN*ELOQ2+CDEN) +! +!---------------------------------------------------------------------- +!*** SM AND SH +!---------------------------------------------------------------------- +! + ESM=(BESM*ELOQ2+CESM)*RDEN + ESH=(BESH*ELOQ2+CESH)*RDEN +! +!---------------------------------------------------------------------- +!*** DIFFUSION COEFFICIENTS +!---------------------------------------------------------------------- +! + RDZ=2./(Z(K)-Z(K+2)) + Q1L=SQRT(Q2(K)) + ELQDZ=ELL*Q1L*RDZ + AKM(K)=ELQDZ*ESM + AKH(K)=ELQDZ*ESH +! if(NTSD.gt.22.and.me.eq.76.and.I.eq.32)then +! if(AKM(K).lt.RDZ*3.)then +! print*,'1K,ELQDZ,ESH,ELL,Q1L,RDZ,Q2=',K,ELQDZ,ESH & +! ,ELL,Q1L,RDZ,Q2(K),BESH,ELOQ2,CESH,RDEN & +! ,ADEN,ELOQ4,BDEN,CDEN,BSHM,GML,BSHH,GHL,BSMH & +! ,BDNM,BDNH,ADNM,ADNH +! else +! print*,'2K,ELQDZ,ESH,ELL,Q1L,RDZ,Q2=',K,ELQDZ,ESH & +! ,ELL,Q1L,RDZ,Q2(K),BESH,ELOQ2,CESH,RDEN & +! ,ADEN,ELOQ4,BDEN,CDEN,BSHM,GML,BSHH,GHL,BSMH & +! ,BDNM,BDNH,ADNM,ADNH +! end if +! if(K.eq.(LMH-1))stop +! end if +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW +! if(K.gt.KPBL)then +! AKM(K)=MAX(AKM(K),RDZ*3.) +! AKH(K)=MAX(AKH(K),RDZ*3.) +! end if +! AKM(K)=MAX(AKM(K),RDZ*3.) +! AKH(K)=MAX(AKH(K),RDZ*3.) +! AKM(K)=MAX(AKM(K),RDZ) +! AKH(K)=MAX(AKH(K),RDZ) +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM +!---------------------------------------------------------------------- + ENDDO +! qingfu test +! K=LM-1 +! RDZ=2./(Z(K)-Z(K+2)) +! AKH(LM-1)=AKH(LM-1)*10. +! AKM(K)=MAX(AKM(K),RDZ*3.)*10. +! AKH(K)=MAX(AKH(K),RDZ*3.)*10. +!---------------------------------------------------------------------- +! +!---------------------------------------------------------------------- +!*** INVERSIONS +!---------------------------------------------------------------------- +! +! IF(LMXL==LMH)THEN +! KINV=LMH +! D2TMIN=0. +! +! DO K=LMH/2,LMH-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! IF(D2T0)THEN +! WRITE(6,"(A,3I3)") '{TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! WRITE(6,"(A,3I3)") '}TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A)") & +! '{TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ELSE +! WRITE(6,"(A)") & +! '}TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ENDIF +! DO K=LMH-1,KINV-1,-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! RDZ=2./(Z(K)-Z(K+2)) +! AKMIN=0.5*RDZ +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '{TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ELSE +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '}TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ENDIF +! ENDDO +! ENDIF !- IF (PRINT_DIAG > 0) THEN +! ENDIF !- IF(KINV Date: Fri, 30 Aug 2019 16:07:57 -0600 Subject: [PATCH 13/36] add calculation of sncovr to GFS_surface_generic_pre_run (not to init because it was originally done after the call to ccpp_physics_init in FV3GFS_io.F90/sfc_prop_restart_read --- physics/GFS_surface_generic.F90 | 45 ++++++++++++++++++++++++++++----- 1 file changed, 38 insertions(+), 7 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 8acf186c1..c867a50dd 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -21,6 +21,7 @@ end subroutine GFS_surface_generic_pre_finalize !! |----------------|------------------------------------------------------------------------------|------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | !! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | +!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | vfrac | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | !! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | !! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | @@ -80,22 +81,26 @@ end subroutine GFS_surface_generic_pre_finalize !! | tsfco | sea_surface_temperature | sea surface temperature | K | 1 | real | kind_phys | in | F | !! | fice | sea_ice_concentration | sea-ice concentration [0,1] | frac | 1 | real | kind_phys | in | F | !! | hice | sea_ice_thickness | sea-ice thickness | m | 1 | real | kind_phys | in | F | +!! | weasd | water_equivalent_accumulated_snow_depth | water equiv of acc snow depth over land and sea ice | mm | 1 | real | kind_phys | in | F | +!! | sncovr | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk, isot, ivegsrc, & + stype, vtype, slope, & prsik_1, prslk_1, semis, adjsfcdlw, tsfc, phil, con_g, sigmaf, soiltyp, vegtype, & slopetyp, work3, gabsbdlw, tsurf, zlvl, do_sppt, dtdtr, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & cplflx, flag_cice, islmsk_cice,slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, ulwsfc_cice, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, & + dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, weasd, sncovr, & errmsg, errflg) use machine, only: kind_phys use surface_perturbation, only: cdfnor + use namelist_soilveg, only: salp_data, snupx implicit none @@ -106,8 +111,8 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1, & - semis, adjsfcdlw - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc + semis, adjsfcdlw, weasd + real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, sncovr real(kind=kind_phys), dimension(im,levs), intent(in) :: phil real(kind=kind_phys), dimension(im), intent(inout) :: sigmaf, work3, gabsbdlw, tsurf, zlvl @@ -133,7 +138,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(im), intent(out) :: xlai1d real(kind=kind_phys), dimension(im), intent(out) :: vegf1d - logical, intent(in) :: cplflx + logical, intent(in) :: cplflx, first_time_step real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl logical, dimension(im), intent(inout) :: flag_cice integer, dimension(im), intent(out) :: islmsk_cice @@ -151,14 +156,40 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, integer :: i real(kind=kind_phys) :: onebg real(kind=kind_phys) :: cdfz - + + !--- local variables for sncovr calculation + integer :: vegtyp + logical :: mand + real(kind=kind_phys) :: rsnow, tem + ! Set constants onebg = 1.0/con_g ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(sncovr(1)) == -9999) then + do i = 1, im + sncovr(i) = 0.0 + if (islmsk(i) > 0) then + ! GJF* this is different than the integer conversion below, but copied from FV3GFS_io.f90. + ! Can this block be moved to after vegetation_type_classification (integer) has been set? *GJF + vegtyp = vtype(i) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*weasd(i)/snupx(vegtyp) + if (0.001*weasd(i) < snupx(vegtyp)) then + sncovr(i) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + sncovr(i) = 1.0 + endif + endif + enddo + endif + endif + ! Set initial quantities for stochastic physics deltas if (do_sppt) then dtdtr = 0.0 From 78523cf154a75d74cf587d8f906a2bbab11457a7 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 3 Sep 2019 11:09:51 -0600 Subject: [PATCH 14/36] add calculation of sncovr to GFS_phys_time_vary_run (not to init because it was originally done after the call to ccpp_physics_init in FV3GFS_io.F90/sfc_prop_restart_read); this needs to happen before radition is called --- physics/GFS_phys_time_vary.fv3.F90 | 38 +++++++++++++++++++++---- physics/GFS_surface_generic.F90 | 45 +++++------------------------- 2 files changed, 40 insertions(+), 43 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index f66a43675..8f20300b6 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -22,6 +22,9 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol + + !--- variables needed for calculating 'sncovr' + use namelist_soilveg, only: salp_data, snupx implicit none @@ -329,23 +332,25 @@ end subroutine GFS_phys_time_vary_finalize !! | Data | GFS_data_type_instance_all_blocks | Fortran DDT containing FV3-GFS data | DDT | 1 | GFS_data_type | | inout | F | !! | Model | GFS_control_type_instance | Fortran DDT containing FV3-GFS model control parameters | DDT | 0 | GFS_control_type | | inout | F | !! | nthrds | omp_threads | number of OpenMP threads available for physics schemes | count | 0 | integer | | in | F | +!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! !>\section gen_GFS_phys_time_vary_run GFS_phys_time_vary_run General Algorithm !> @{ - subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) + subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, errflg) use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_data_type - + implicit none ! Interface variables - type(GFS_data_type), intent(in) :: Data(:) + type(GFS_data_type), intent(inout) :: Data(:) type(GFS_control_type), intent(inout) :: Model integer, intent(in) :: nthrds + logical, intent(in) :: first_time_step character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -354,8 +359,8 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - integer :: i, j, k, iseed, iskip, ix, nb, nblks, kdt_rad - real(kind=kind_phys) :: sec_zero + integer :: i, j, k, iseed, iskip, ix, nb, nblks, kdt_rad, vegtyp + real(kind=kind_phys) :: sec_zero, rsnow real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(Model%cny) real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) @@ -508,6 +513,29 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, errmsg, errflg) enddo endif endif + + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do nb = 1, nblks + do ix = 1, Model%blksz(nb) + Data(nb)%Sfcprop%sncovr(ix) = 0.0 + if (Data(nb)%Sfcprop%slmsk(ix) > 0.001) then + vegtyp = Data(nb)%Sfcprop%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Data(nb)%Sfcprop%weasd(ix)/snupx(vegtyp) + if (0.001*Data(nb)%Sfcprop%weasd(ix) < snupx(vegtyp)) then + Data(nb)%Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Data(nb)%Sfcprop%sncovr(ix) = 1.0 + endif + endif + enddo + enddo + endif + endif end subroutine GFS_phys_time_vary_run !> @} diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index c867a50dd..8acf186c1 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -21,7 +21,6 @@ end subroutine GFS_surface_generic_pre_finalize !! |----------------|------------------------------------------------------------------------------|------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | !! | levs | vertical_dimension | number of vertical levels | count | 0 | integer | | in | F | -!! | first_time_step | flag_for_first_time_step | flag for first time step for time integration loop (cold/warmstart) | flag | 0 | logical | | in | F | !! | vfrac | vegetation_area_fraction | areal fractional cover of green vegetation | frac | 1 | real | kind_phys | in | F | !! | islmsk | sea_land_ice_mask | landmask: sea/land/ice=0/1/2 | flag | 1 | integer | | in | F | !! | isot | soil_type_dataset_choice | soil type dataset choice | index | 0 | integer | | in | F | @@ -81,26 +80,22 @@ end subroutine GFS_surface_generic_pre_finalize !! | tsfco | sea_surface_temperature | sea surface temperature | K | 1 | real | kind_phys | in | F | !! | fice | sea_ice_concentration | sea-ice concentration [0,1] | frac | 1 | real | kind_phys | in | F | !! | hice | sea_ice_thickness | sea-ice thickness | m | 1 | real | kind_phys | in | F | -!! | weasd | water_equivalent_accumulated_snow_depth | water equiv of acc snow depth over land and sea ice | mm | 1 | real | kind_phys | in | F | -!! | sncovr | surface_snow_area_fraction_over_land | surface snow area fraction | frac | 1 | real | kind_phys | inout | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk, isot, ivegsrc, & - stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & prsik_1, prslk_1, semis, adjsfcdlw, tsfc, phil, con_g, sigmaf, soiltyp, vegtype, & slopetyp, work3, gabsbdlw, tsurf, zlvl, do_sppt, dtdtr, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & cplflx, flag_cice, islmsk_cice,slimskin_cpl, dusfcin_cpl, dvsfcin_cpl, & dtsfcin_cpl, dqsfcin_cpl, ulwsfcin_cpl, ulwsfc_cice, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, weasd, sncovr, & + dtsfc_cice, dqsfc_cice, tisfc, tsfco, fice, hice, & errmsg, errflg) use machine, only: kind_phys use surface_perturbation, only: cdfnor - use namelist_soilveg, only: salp_data, snupx implicit none @@ -111,8 +106,8 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(im), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1, & - semis, adjsfcdlw, weasd - real(kind=kind_phys), dimension(im), intent(inout) :: tsfc, sncovr + semis, adjsfcdlw + 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, gabsbdlw, tsurf, zlvl @@ -138,7 +133,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk real(kind=kind_phys), dimension(im), intent(out) :: xlai1d real(kind=kind_phys), dimension(im), intent(out) :: vegf1d - logical, intent(in) :: cplflx, first_time_step + 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 @@ -156,40 +151,14 @@ subroutine GFS_surface_generic_pre_run (im, levs, first_time_step, vfrac, islmsk integer :: i real(kind=kind_phys) :: onebg real(kind=kind_phys) :: cdfz - - !--- local variables for sncovr calculation - integer :: vegtyp - logical :: mand - real(kind=kind_phys) :: rsnow, tem - + ! Set constants onebg = 1.0/con_g ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) - if (first_time_step) then - if (nint(sncovr(1)) == -9999) then - do i = 1, im - sncovr(i) = 0.0 - if (islmsk(i) > 0) then - ! GJF* this is different than the integer conversion below, but copied from FV3GFS_io.f90. - ! Can this block be moved to after vegetation_type_classification (integer) has been set? *GJF - vegtyp = vtype(i) - if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*weasd(i)/snupx(vegtyp) - if (0.001*weasd(i) < snupx(vegtyp)) then - sncovr(i) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) - else - sncovr(i) = 1.0 - endif - endif - enddo - endif - endif - + ! Set initial quantities for stochastic physics deltas if (do_sppt) then dtdtr = 0.0 From af34508ebf09785fdd1584d297f1a93759a8c132 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 3 Sep 2019 16:13:37 -0600 Subject: [PATCH 15/36] fix GFS_time_vary_pre.fv3.F90 compilation error --- physics/GFS_time_vary_pre.fv3.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 450a5af4d..8f146de92 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -164,11 +164,11 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- allow for radiation to be called on every physics time step, if needed - if (Model%nsswr == 1) Model%lsswr = .true. - if (Model%nslwr == 1) Model%lslwr = .true. + if (nsswr == 1) lsswr = .true. + if (nslwr == 1) lslwr = .true. !--- set the solar hour based on a combination of phour and time initial hour solhr = mod(phour+idate(1),con_24) From 619afe09f93d77a2462281968339adaad7b455fc Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 4 Sep 2019 13:04:08 -0600 Subject: [PATCH 16/36] add calculation of precipitation variables for NoahMP in GFS_MP_generic_post_run --- physics/GFS_MP_generic.F90 | 33 ++++++++++++++++++++++++++++++--- 1 file changed, 30 insertions(+), 3 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 8d3074988..70efd23bf 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -165,11 +165,17 @@ end subroutine GFS_MP_generic_post_init !! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | inout | F | !! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | !! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | +!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | !! | raincprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | rainncprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | !! | iceprv | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | snowprv | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | graupelprv | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | inout | F | +!! | rainc_mp | convective_precipitation_rate_from_previous_timestep | convective precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | rainn_mp | explicit_rainfall_rate_from_previous_timestep | explicit rainfall rate previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | ice_mp | ice_precipitation_rate_from_previous_timestep | ice precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | snow_mp | snow_precipitation_rate_from_previous_timestep | snow precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | +!! | graupel_mp | graupel_precipitation_rate_from_previous_timestep | graupel precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | !! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | @@ -181,8 +187,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt 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, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, & - dtp, errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & + graupelprv, dtp, rainc_mp, rainn_mp, ice_mp, snow_mp, graupel_mp, errmsg, errflg) ! use machine, only: kind_phys @@ -225,7 +231,15 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv real(kind=kind_phys), intent(in) :: dtp - + + ! Rainfall variables previous time step (update for NoahMP LSM) + integer, intent(in) :: lsm_noahmp + real(kind=kind_phys), dimension(im), intent(inout) :: rainc_mp + real(kind=kind_phys), dimension(im), intent(inout) :: rainn_mp + real(kind=kind_phys), dimension(im), intent(inout) :: ice_mp + real(kind=kind_phys), dimension(im), intent(inout) :: snow_mp + real(kind=kind_phys), dimension(im), intent(inout) :: graupel_mp + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -286,6 +300,19 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt graupelprv(:) = graupel(:) end if end if + + !--- get the amount of different precip type for Noah MP + ! --- convert from m/dtp to mm/s + if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then + tem = 1.0 / (dtp*con_p001) + do i=1,im + rainn_mp(i) = tem * (rain(i)-rainc(i)) + rainc_mp(i) = tem * rainc(i) + snow_mp(i) = tem * snow(i) + graupel_mp(i) = tem * graupel(i) + ice_mp(i) = tem * ice(i) + enddo + endif if (cal_pre) then ! hchuang: add dominant precipitation type algorithm ! From de728a80e66f03b203865fc756823c0068215abb Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 4 Sep 2019 22:14:12 -0600 Subject: [PATCH 17/36] add resetting of sfcprop%t2m and q2m to values from noahmp if noahmp is active --- physics/GFS_MP_generic.F90 | 10 +++++----- physics/sfc_diag_post.F90 | 32 ++++++++++++++++++++++++-------- physics/sfc_noahmp_drv.f | 22 +++++++++------------- physics/sfc_noahmp_drv.meta | 36 ++++++++++++++++++------------------ 4 files changed, 56 insertions(+), 44 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 70efd23bf..5fa9614d7 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -234,11 +234,11 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt ! Rainfall variables previous time step (update for NoahMP LSM) integer, intent(in) :: lsm_noahmp - real(kind=kind_phys), dimension(im), intent(inout) :: rainc_mp - real(kind=kind_phys), dimension(im), intent(inout) :: rainn_mp - real(kind=kind_phys), dimension(im), intent(inout) :: ice_mp - real(kind=kind_phys), dimension(im), intent(inout) :: snow_mp - real(kind=kind_phys), dimension(im), intent(inout) :: graupel_mp + real(kind=kind_phys), dimension(:), intent(inout) :: rainc_mp + real(kind=kind_phys), dimension(:), intent(inout) :: rainn_mp + real(kind=kind_phys), dimension(:), intent(inout) :: ice_mp + real(kind=kind_phys), dimension(:), intent(inout) :: snow_mp + real(kind=kind_phys), dimension(:), intent(inout) :: graupel_mp ! CCPP error handling character(len=*), intent(out) :: errmsg diff --git a/physics/sfc_diag_post.F90 b/physics/sfc_diag_post.F90 index 80c90eadb..054e1ab24 100644 --- a/physics/sfc_diag_post.F90 +++ b/physics/sfc_diag_post.F90 @@ -15,13 +15,18 @@ end subroutine sfc_diag_post_finalize !! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | !! |----------------|---------------------------------------------------------------------------------------------------------------------|-------------------------------------------------------------------------------------|-------------|------|------------|-----------|--------|----------| !! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | +!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | +!! | dry | flag_nonzero_land_surface_fraction | flag indicating presence of some land surface area fraction | flag | 1 | logical | | in | F | !! | lssav | flag_diagnostics | logical flag for storing diagnostics | flag | 0 | logical | | in | F | !! | dtf | time_step_for_dynamics | dynamics timestep | s | 0 | real | kind_phys | in | F | !! | con_eps | ratio_of_dry_air_to_water_vapor_gas_constants | rd/rv | none | 0 | real | kind_phys | in | F | !! | con_epsm1 | ratio_of_dry_air_to_water_vapor_gas_constants_minus_one | (rd/rv) - 1 | none | 0 | real | kind_phys | in | F | !! | pgr | surface_air_pressure | surface pressure | Pa | 1 | real | kind_phys | in | F | -!! | t2m | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | in | F | -!! | q2m | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | in | F | +!! | t2mmp | temperature_at_2m_from_noahmp | 2 meter temperature from NoahMP | K | 1 | real | kind_phys | in | F | +!! | q2mp | specific_humidity_at_2m_from_noahmp | 2 meter specific humidity from noahmp | kg kg-1 | 1 | real | kind_phys | in | F | +!! | t2m | temperature_at_2m | 2 meter temperature | K | 1 | real | kind_phys | inout | F | +!! | q2m | specific_humidity_at_2m | 2 meter specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | !! | u10m | x_wind_at_10m | 10 meter u wind speed | m s-1 | 1 | real | kind_phys | in | F | !! | v10m | y_wind_at_10m | 10 meter v wind speed | m s-1 | 1 | real | kind_phys | in | F | !! | tmpmin | minimum_temperature_at_2m | min temperature at 2m height | K | 1 | real | kind_phys | inout | F | @@ -36,19 +41,21 @@ end subroutine sfc_diag_post_finalize !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | !! #endif - subroutine sfc_diag_post_run (im, lssav, dtf, con_eps, con_epsm1, pgr, & - t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax,& + subroutine sfc_diag_post_run (im, lsm, lsm_noahmp, dry, lssav, dtf, con_eps, con_epsm1, pgr,& + t2mmp, q2mp, t2m, q2m, u10m, v10m, tmpmin, tmpmax, spfhmin, spfhmax,& wind10mmax, u10mmax, v10mmax, dpt2m, errmsg, errflg) use machine, only: kind_phys implicit none - integer, intent(in) :: im + integer, intent(in) :: im, lsm, lsm_noahmp logical, intent(in) :: lssav real(kind=kind_phys), intent(in) :: dtf, con_eps, con_epsm1 - real(kind=kind_phys), dimension(im), intent(in) :: pgr, t2m, q2m, u10m, v10m - real(kind=kind_phys), dimension(im), intent(inout) :: tmpmin, tmpmax, spfhmin, spfhmax + logical , dimension(im), intent(in) :: dry + real(kind=kind_phys), dimension(im), intent(in) :: pgr, u10m, v10m + real(kind=kind_phys), dimension(:) , intent(in) :: t2mmp, q2mp + real(kind=kind_phys), dimension(im), intent(inout) :: t2m, q2m, tmpmin, tmpmax, spfhmin, spfhmax real(kind=kind_phys), dimension(im), intent(inout) :: wind10mmax, u10mmax, v10mmax, dpt2m character(len=*), intent(out) :: errmsg @@ -60,7 +67,16 @@ subroutine sfc_diag_post_run (im, lssav, dtf, con_eps, con_epsm1, pgr, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + + if (lsm == lsm_noahmp) then + do i=1,im + if(dry(i)) then + t2m(i) = t2mmp(i) + q2m(i) = q2mp(i) + endif + enddo + endif + if (lssav) then do i=1,im tmpmax(i) = max(tmpmax(i),t2m(i)) diff --git a/physics/sfc_noahmp_drv.f b/physics/sfc_noahmp_drv.f index 7d8b60d5f..a089e84d0 100755 --- a/physics/sfc_noahmp_drv.f +++ b/physics/sfc_noahmp_drv.f @@ -58,7 +58,7 @@ subroutine noahmpdrv_run & ! --- in/outs: & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & - & canopy, trans, tsurf, zorl, t2mmp, q2mp, & + & canopy, trans, tsurf, zorl, & ! --- Noah MP specific @@ -71,7 +71,7 @@ subroutine noahmpdrv_run & ! --- outputs: & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & - & smcwlt2, smcref2, wet1, errmsg, errflg) + & smcwlt2, smcref2, wet1, t2mmp, q2mp, errmsg, errflg) ! ! use machine , only : kind_phys @@ -143,8 +143,7 @@ subroutine noahmpdrv_run & ! --- in/out: real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & - & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl, & - & t2mmp, q2mp + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl real (kind=kind_phys), dimension(im,km), intent(inout) :: & & smc, stc, slc @@ -170,7 +169,8 @@ subroutine noahmpdrv_run & real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & - & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1 + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, wet1 + real (kind=kind_phys), dimension(:), intent(out) :: t2mmp, q2mp ! error messages character(len=*), intent(out) :: errmsg @@ -698,10 +698,8 @@ subroutine noahmpdrv_run & z0wrf = 0.002 eta = fgev - if (dry(i)) then - t2mmp(i) = t2mb - q2mp(i) = q2b - endif + t2mmp(i) = t2mb + q2mp(i) = q2b ! ! Non-glacial case ! @@ -749,10 +747,8 @@ subroutine noahmpdrv_run & eta = fcev + fgev + fctr ! the flux w/m2 - if (dry(i)) then - t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) - q2mp(i) = q2v*fveg+q2b*(1-fveg) - endif + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) endif ! glacial split ends diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 2a604fc15..9baa85082 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -690,24 +690,6 @@ kind = kind_phys intent = inout optional = F -[t2mmp] - standard_name = temperature_at_2m - long_name = 2 meter temperature - units = K - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[q2mp] - standard_name = specific_humidity_at_2m - long_name = 2 meter specific humidity - units = kg kg-1 - dimensions = (horizontal_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers @@ -1185,6 +1167,24 @@ kind = kind_phys intent = out optional = F +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 775f4ffe9d11c5cd1d7718423d1fe4983967fb41 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 6 Sep 2019 15:16:32 -0600 Subject: [PATCH 18/36] (temporarily?) move calculation of precip rates for NoahMP to scheme-specific interstitial to test for b4b --- physics/GFS_MP_generic.F90 | 31 +------ physics/sfc_noahmp_pre.F90 | 65 ++++++++++++++ physics/sfc_noahmp_pre.meta | 167 ++++++++++++++++++++++++++++++++++++ 3 files changed, 234 insertions(+), 29 deletions(-) create mode 100755 physics/sfc_noahmp_pre.F90 create mode 100644 physics/sfc_noahmp_pre.meta diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 5fa9614d7..3e6a8379c 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -165,17 +165,11 @@ end subroutine GFS_MP_generic_post_init !! | dsnow_cpl | tendency_of_lwe_thickness_of_snow_amount_for_coupling | change in show_cpl (coupling_type) | m | 1 | real | kind_phys | inout | F | !! | lsm | flag_for_land_surface_scheme | flag for land surface model | flag | 0 | integer | | in | F | !! | lsm_ruc | flag_for_ruc_land_surface_scheme | flag for RUC land surface model | flag | 0 | integer | | in | F | -!! | lsm_noahmp | flag_for_noahmp_land_surface_scheme | flag for NOAH MP land surface model | flag | 0 | integer | | in | F | !! | raincprv | lwe_thickness_of_convective_precipitation_amount_from_previous_timestep | convective_precipitation_amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | rainncprv | lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep | explicit rainfall from previous timestep | m | 1 | real | kind_phys | inout | F | !! | iceprv | lwe_thickness_of_ice_amount_from_previous_timestep | ice amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | snowprv | lwe_thickness_of_snow_amount_from_previous_timestep | snow amount from previous timestep | m | 1 | real | kind_phys | inout | F | !! | graupelprv | lwe_thickness_of_graupel_amount_from_previous_timestep | graupel amount from previous timestep | m | 1 | real | kind_phys | inout | F | -!! | rainc_mp | convective_precipitation_rate_from_previous_timestep | convective precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | rainn_mp | explicit_rainfall_rate_from_previous_timestep | explicit rainfall rate previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | ice_mp | ice_precipitation_rate_from_previous_timestep | ice precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | snow_mp | snow_precipitation_rate_from_previous_timestep | snow precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | -!! | graupel_mp | graupel_precipitation_rate_from_previous_timestep | graupel precipitation rate from previous timestep | mm s-1 | 1 | real | kind_phys | inout | F | !! | dtp | time_step_for_physics | physics timestep | s | 0 | real | kind_phys | in | F | !! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | !! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | @@ -187,8 +181,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt 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, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & - graupelprv, dtp, rainc_mp, rainn_mp, ice_mp, snow_mp, graupel_mp, errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, dtp, & + errmsg, errflg) ! use machine, only: kind_phys @@ -232,14 +226,6 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), intent(in) :: dtp - ! Rainfall variables previous time step (update for NoahMP LSM) - integer, intent(in) :: lsm_noahmp - real(kind=kind_phys), dimension(:), intent(inout) :: rainc_mp - real(kind=kind_phys), dimension(:), intent(inout) :: rainn_mp - real(kind=kind_phys), dimension(:), intent(inout) :: ice_mp - real(kind=kind_phys), dimension(:), intent(inout) :: snow_mp - real(kind=kind_phys), dimension(:), intent(inout) :: graupel_mp - ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -300,19 +286,6 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt graupelprv(:) = graupel(:) end if end if - - !--- get the amount of different precip type for Noah MP - ! --- convert from m/dtp to mm/s - if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then - tem = 1.0 / (dtp*con_p001) - do i=1,im - rainn_mp(i) = tem * (rain(i)-rainc(i)) - rainc_mp(i) = tem * rainc(i) - snow_mp(i) = tem * snow(i) - graupel_mp(i) = tem * graupel(i) - ice_mp(i) = tem * ice(i) - enddo - endif if (cal_pre) then ! hchuang: add dominant precipitation type algorithm ! diff --git a/physics/sfc_noahmp_pre.F90 b/physics/sfc_noahmp_pre.F90 new file mode 100755 index 000000000..fff3562d6 --- /dev/null +++ b/physics/sfc_noahmp_pre.F90 @@ -0,0 +1,65 @@ +!> \file sfc_noahmp_pre.F90 +!! This file contains data preparation for the NoahMP LSM for use in the GFS physics suite. + +!> This module contains the CCPP-compliant data preparation for NoahMP LSM. + module sfc_noahmp_pre + + implicit none + + private + + public :: sfc_noahmp_pre_init, sfc_noahmp_pre_run, sfc_noahmp_pre_finalize + + contains + + subroutine sfc_noahmp_pre_init() + end subroutine sfc_noahmp_pre_init + + subroutine sfc_noahmp_pre_finalize + end subroutine sfc_noahmp_pre_finalize + +!> \section arg_table_sfc_noahmp_pre_run Argument Table +!! \htmlinclude sfc_noahmp_pre_run.html +!! +!----------------------------------- + subroutine sfc_noahmp_pre_run (im, lsm, lsm_noahmp, imp_physics, & + imp_physics_gfdl, imp_physics_mg, dtp, rain, rainc, ice, snow, & + graupel, rainn_mp, rainc_mp, ice_mp, snow_mp, graupel_mp, & + errmsg, errflg) + + use machine , only : kind_phys + + implicit none + + integer, intent(in) :: im, lsm, lsm_noahmp, & + imp_physics, imp_physics_gfdl, imp_physics_mg + real (kind=kind_phys), intent(in) :: dtp + real (kind=kind_phys), dimension(im), intent(in) :: rain, rainc,& + ice, snow, graupel + real (kind=kind_phys), dimension(:), intent(inout) :: rainn_mp, & + rainc_mp, ice_mp, snow_mp, graupel_mp + + ! error messages + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! --- locals: + integer :: i + real(kind=kind_phys) :: tem + real(kind=kind_phys), parameter :: con_p001= 0.001d0 + + !--- get the amount of different precip type for Noah MP + ! --- convert from m/dtp to mm/s + if (lsm == lsm_noahmp .and. (imp_physics == imp_physics_mg .or. imp_physics == imp_physics_gfdl)) then + tem = 1.0 / (dtp*con_p001) + do i=1,im + rainn_mp(i) = tem * (rain(i)-rainc(i)) + rainc_mp(i) = tem * rainc(i) + snow_mp(i) = tem * snow(i) + graupel_mp(i) = tem * graupel(i) + ice_mp(i) = tem * ice(i) + enddo + endif + + end subroutine sfc_noahmp_pre_run + end module sfc_noahmp_pre diff --git a/physics/sfc_noahmp_pre.meta b/physics/sfc_noahmp_pre.meta new file mode 100644 index 000000000..4cf834728 --- /dev/null +++ b/physics/sfc_noahmp_pre.meta @@ -0,0 +1,167 @@ +[ccpp-arg-table] + name = sfc_noahmp_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + 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 +[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_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 +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[rain] + standard_name = lwe_thickness_of_precipitation_amount_on_dynamics_timestep + long_name = total rain at this time step + units = m + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + 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_dimension) + type = real + kind = kind_phys + intent = in + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[rainn_mp] + standard_name = explicit_rainfall_rate_from_previous_timestep + long_name = explicit rainfall rate previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rainc_mp] + standard_name = convective_precipitation_rate_from_previous_timestep + long_name = convective precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ice_mp] + standard_name = ice_precipitation_rate_from_previous_timestep + long_name = ice precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snow_mp] + standard_name = snow_precipitation_rate_from_previous_timestep + long_name = snow precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[graupel_mp] + standard_name = graupel_precipitation_rate_from_previous_timestep + long_name = graupel precipitation rate from previous timestep + units = mm s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From e7bb31a6360b23d8b5c0845409648f9342e2dfa7 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Tue, 10 Sep 2019 17:23:59 -0600 Subject: [PATCH 19/36] revert whitespace changes to GFS_MP_generic.F90 --- physics/GFS_MP_generic.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 85f9333e6..b83f592f2 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -85,8 +85,8 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt 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, & - do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, dtp, & - errmsg, errflg) + do_sppt, dtdtr, dtdtc, drain_cpl, dsnow_cpl, lsm, lsm_ruc, raincprv, rainncprv, iceprv, snowprv, graupelprv, & + dtp, errmsg, errflg) ! use machine, only: kind_phys @@ -129,7 +129,7 @@ subroutine GFS_MP_generic_post_run(im, ix, levs, kdt, nrcm, ncld, nncl, ntcw, nt real(kind=kind_phys), dimension(im), intent(inout) :: graupelprv real(kind=kind_phys), intent(in) :: dtp - + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg From 69c215f7f628bb1868d303db9187744d3c2f3aea Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Thu, 12 Sep 2019 11:59:38 -0600 Subject: [PATCH 20/36] fix bug in metadata table for GFS_phys_time_vary_run for FV3 --- physics/GFS_phys_time_vary.fv3.meta | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index cccc1eaa1..ac2ccbf3c 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -33,14 +33,6 @@ type = integer intent = in optional = F -[first_time_step] - standard_name = flag_for_first_time_step - long_name = flag for first time step for time integration loop (cold/warmstart) - units = flag - dimensions = () - type = logical - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -109,6 +101,14 @@ type = integer intent = in optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 822c6479bd92563fffc11326db8a96b6b4b6e060 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 14:09:34 -0600 Subject: [PATCH 21/36] Revert changes to physics/module_BL_MYJPBL.F90 physics/module_SF_JSFC.F90 that replaced legacy code (GOTO statements) with more complicated code --- physics/module_BL_MYJPBL.F90 | 112 ++++++++++------------------------- physics/module_SF_JSFC.F90 | 6 +- 2 files changed, 34 insertions(+), 84 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index f0ddbd86b..6f455221b 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -915,7 +915,7 @@ SUBROUTINE MIXLEN & !--------1---------2---------3---------4---------5---------6---------7-- CUBRY=UBRY*1.5 !*2. !--------------FIND THE HEIGHT OF THE PBL------------------------------- - LPBL=LMH/3 + LPBL=LMH ! LPBL=LMH-1 DO K=LMH-1,1,-1 ! EPSL(K)=1. @@ -928,11 +928,11 @@ SUBROUTINE MIXLEN & DO K=LMH-1,1,-1 if(q2(k)-epsq2(k)+epsq2(lm).le.epsq2(lm)*fh) then LPBL=K -!QL GO TO 110 + GO TO 110 ENDIF ENDDO ! -!QL LPBL=1 + LPBL=1 ! !--------------THE HEIGHT OF THE PBL------------------------------------ ! @@ -2117,12 +2117,10 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) Q(1)=-RTDXC*DXR ! -!QL IF(NOLD.EQ.3) GO TO 700 - IF(NOLD.NE.3) THEN + IF(NOLD.EQ.3) GO TO 700 !----------------------------------------------------------------------- -! K=3 + K=3 ! - DO K=3,NOLD-1 100 DXL=DXR DYDXL=DYDXR DXR=XOLD(K+1)-XOLD(K) @@ -2133,97 +2131,49 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) Q(K-1)=-DEN*DXR ! -! K=K+1 -!QL IF(K.LT.NOLD) GO TO 100 - END DO - END IF + K=K+1 + IF(K.LT.NOLD) GO TO 100 !----------------------------------------------------------------------- -!QL 700 K=NOLDM1 -! K=NOLDM1 -! - DO K=NOLDM1, 2, -1 + 700 K=NOLDM1 +! 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) ! -! K=K-1 -!QL IF(K.GT.1) GO TO 200 - END DO + K=K-1 + IF(K.GT.1) GO TO 200 !----------------------------------------------------------------------- -! K1=1 + K1=1 ! - DO K1=1,NNEW 300 XK=XNEW(K1) ! - YNEW(K1)=YOLD(NOLD) DO 400 K2=2,NOLD - IF(XOLD(K2).LE.XK) CYCLE + IF(XOLD(K2).LE.XK) GO TO 400 KOLD=K2-1 -!QL GO TO 450 - IF(K1.EQ.1)THEN ! 450 - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - EXIT - END IF - - IF(K.EQ.KOLD)THEN ! 550 - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) - EXIT - END IF - - K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) - X=XK-XOLD(K) - XSQ=X*X - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - EXIT - + GO TO 450 400 CONTINUE -! GO TO 600 + YNEW(K1)=YOLD(NOLD) + GO TO 600 ! -! 450 IF(K1.EQ.1) GO TO 500 -! IF(K.EQ.KOLD) GO TO 550 + 450 IF(K1.EQ.1) GO TO 500 + IF(K.EQ.KOLD) GO TO 550 ! -! 500 K=KOLD + 500 K=KOLD ! -! Y2K=Y2(K) -! Y2KP1=Y2(K+1) -! DX=XOLD(K+1)-XOLD(K) -! RDX=1./DX + Y2K=Y2(K) + Y2KP1=Y2(K+1) + DX=XOLD(K+1)-XOLD(K) + RDX=1./DX ! -! AK=.1666667*RDX*(Y2KP1-Y2K) -! BK=.5*Y2K -! CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) + AK=.1666667*RDX*(Y2KP1-Y2K) + BK=.5*Y2K + CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) ! -! 550 X=XK-XOLD(K) -! XSQ=X*X + 550 X=XK-XOLD(K) + XSQ=X*X ! -! YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) + YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) ! -! 600 K1=K1+1 -! IF(K1.LE.NNEW) GO TO 300 - END DO + 600 K1=K1+1 + IF(K1.LE.NNEW) GO TO 300 !----------------------------------------------------------------------- ENDSUBROUTINE SPLINE !----------------------------------------------------------------------- diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 41c546d42..0c79f8de1 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -327,15 +327,15 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ! !*** FIND THE HEIGHT OF THE PBL ! - LPBL=LMH/3 + LPBL=LMH DO K=LMH-1,1,-1 IF(Q2K(K)<=EPSQ2(K)*FH) THEN LPBL=K -! GO TO 110 + GO TO 110 ENDIF ENDDO ! -! LPBL=1 + LPBL=1 ! !----------------------------------------------------------------------- !--------------THE HEIGHT OF THE PBL------------------------------------ From 248af59781eea8027d137564bc513ff59332598c Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 15:07:02 -0600 Subject: [PATCH 22/36] Convert physics/module_MYJPBL_wrapper.F90 and physics/module_MYJSFC_wrapper.F90 to new metadata format --- physics/module_MYJPBL_wrapper.F90 | 77 +-- physics/module_MYJPBL_wrapper.meta | 651 +++++++++++++++++++++++ physics/module_MYJSFC_wrapper.F90 | 95 +--- physics/module_MYJSFC_wrapper.meta | 814 +++++++++++++++++++++++++++++ 4 files changed, 1467 insertions(+), 170 deletions(-) create mode 100644 physics/module_MYJPBL_wrapper.meta create mode 100644 physics/module_MYJSFC_wrapper.meta diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index ce1c95830..8114afea4 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -15,82 +15,7 @@ end subroutine myjpbl_wrapper_finalize !> \brief This scheme (1) performs pre-myjpbl work, (2) runs the myjpbl, and (3) performs post-myjpbl work #if 0 !! \section arg_table_myjpbl_wrapper_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |---------------------|-----------------------------------------------------------------|-------------------------------------------------- ----|---------------|------|------------------|-----------|--------|----------| -!! | restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | do_myjsfc | do_myjsfc | flag for MYJ surface layer scheme | flag | 0 | logical | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | dt_phs | time_step_for_physics | time step for physics | s | 0 | real | kind_phys | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | ntrac | number_of_vertical_diffusion_tracers | number of tracers to diffuse vertically | count | 0 | integer | | in | F | -!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | ntrw | index_for_rain_water | tracer index for rain water | index | 0 | integer | | in | F | -!! | ntsw | index_for_snow_water | tracer index for snow water | index | 0 | integer | | in | F | -!! | ntgl | index_for_graupel | tracer index for graupel | index | 0 | integer | | in | F | -!! | ugrs | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vgrs | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tgrs | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qgrs | vertically_diffused_tracer_concentration | tracer concentration diffused by PBL scheme | kg kg-1 | 3 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | hprime1 | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | -!! | prsik_1 | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at lowest model interface| none | 1 | real | kind_phys | in | F | -!! | prslk_1 | dimensionless_exner_function_at_lowest_model_layer | dimensionless Exner function at lowest model layer | none | 1 | real | kind_phys | in | F | -!! | prslki | ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer | Exner function ratio bt midlayer and interface at 1st layer | ratio | 1 | real | kind_phys | in | F | -!! | tsfc | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | inout | F | -!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_qsfc | surface_specific_humidity_for_MYJ_schemes | surface air saturation specific humidity for MYJ schem| kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_thz0 | potential_temperature_at_viscous_sublayer_top | potential temperat at viscous sublayer top over water | K | 1 | real | kind_phys | inout | F | -!! | phy_myj_qz0 | specific_humidity_at_viscous_sublayer_top | specific humidity at_viscous sublayer top over water | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_uz0 | u_wind_component_at_viscous_sublayer_top | u wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_vz0 | v_wind_component_at_viscous_sublayer_top | v wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_z0base | baseline_surface_roughness_length | baseline surface roughness length for momentum in mete| m | 1 | real | kind_phys | inout | F | -!! | phy_myj_akhs | heat_exchange_coefficient_for_MYJ_schemes | surface heat exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_akms | momentum_exchange_coefficient_for_MYJ_schemes | surface momentum exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_chkqlm | surface_layer_evaporation_switch | surface layer evaporation switch | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_elflx | kinematic_surface_latent_heat_flux | kinematic surface latent heat flux | m s-1 kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1u | weight_for_momentum_at_viscous_sublayer_top | Weight for momentum at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1t | weight_for_potental_temperature_at_viscous_sublayer_top | Weight for potental temperature at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1q | weight_for_specific_humidity_at_viscous_sublayer_top | Weight for Specfic Humidity at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | pblh | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | out | F | -!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | PBL top model level index | index | 1 | integer | | out | F | -!! | kinver | index_of_highest_temperature_inversion | index of highest temperature inversion | index | 1 | integer | | in | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | garea | cell_area | area of the grid cell | m2 | 1 | real | kind_phys | in | F | -!! | ustar | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | -!! | cm | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | -!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | -!! | wind | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | in | F | -!! | snowd | surface_snow_thickness_water_equivalent | water equivalent snow depth over land | mm | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length in cm | cm | 1 | real | kind_phys | inout | F | -!! | hflx | kinematic_surface_upward_sensible_heat_flux | kinematic surface upward sensible heat flux | K m s-1 | 1 | real | kind_phys | in | F | -!! | evap | kinematic_surface_upward_latent_heat_flux | kinematic surface upward latent heat flux | kg kg-1 m s-1 | 1 | real | kind_phys | in | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | updated tendency of the x wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | updated tendency of the y wind | m s-2 | 2 | real | kind_phys | inout | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | updated tendency of the temperature | K s-1 | 2 | real | kind_phys | inout | F | -!! | dqdt | tendency_of_vertically_diffused_tracer_concentration | updated tendency of the tracers PBL vertical diff | kg kg-1 s-1 | 3 | real | kind_phys | inout | F | -!! | dusfc | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | out | F | -!! | dtsfc | instantaneous_surface_upward_sensible_heat_flux | surface upward sensible heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dqsfc | instantaneous_surface_upward_latent_heat_flux | surface upward latent heat flux | W m-2 | 1 | real | kind_phys | out | F | -!! | dkt | atmosphere_heat_diffusivity | diffusivity for heat | m2 s-1 | 2 | real | kind_phys | out | F | -!! | xkzm_m | atmosphere_momentum_diffusivity_background | background value of momentum diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_h | atmosphere_heat_diffusivity_background | background value of heat diffusivity | m2 s-1 | 0 | real | kind_phys | in | F | -!! | xkzm_s | diffusivity_background_sigma_level | sigma level threshold for background diffusivity | none | 0 | real | kind_phys | in | F | -!! | gamt | countergradient_mixing_term_for_temperature | countergradient mixing term for temperature | K | 1 | real | kind_phys | inout | F | -!! | gamq | countergradient_mixing_term_for_water_vapor | countergradient mixing term for water vapor | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude myjpbl_wrapper_run.html !! #endif !###=================================================================== diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta new file mode 100644 index 000000000..a70203def --- /dev/null +++ b/physics/module_MYJPBL_wrapper.meta @@ -0,0 +1,651 @@ +[ccpp-arg-table] + name = myjpbl_wrapper_run + type = scheme +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[do_myjsfc] + standard_name = do_myjsfc + long_name = flag for MYJ surface layer scheme + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[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 +[dt_phs] + standard_name = time_step_for_physics + long_name = time step for physics + units = s + dimensions = () + type = real + kind = kind_phys + 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 +[ntrac] + standard_name = number_of_vertical_diffusion_tracers + long_name = number of tracers to diffuse vertically + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = cloud condensate index in tracer array + 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 +[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 +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qgrs] + standard_name = vertically_diffused_tracer_concentration + long_name = tracer concentration diffused by PBL scheme + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,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_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[hprime1] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[qsfc] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qsfc] + standard_name = surface_specific_humidity_for_MYJ_schemes + long_name = surface air saturation specific humidity for MYJ schem + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_thz0] + standard_name = potential_temperature_at_viscous_sublayer_top + long_name = potential temperat at viscous sublayer top over water + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qz0] + standard_name = specific_humidity_at_viscous_sublayer_top + long_name = specific humidity at_viscous sublayer top over water + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_uz0] + standard_name = u_wind_component_at_viscous_sublayer_top + long_name = u wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_vz0] + standard_name = v_wind_component_at_viscous_sublayer_top + long_name = v wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_z0base] + standard_name = baseline_surface_roughness_length + long_name = baseline surface roughness length for momentum in mete + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akhs] + standard_name = heat_exchange_coefficient_for_MYJ_schemes + long_name = surface heat exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akms] + standard_name = momentum_exchange_coefficient_for_MYJ_schemes + long_name = surface momentum exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_chkqlm] + standard_name = surface_layer_evaporation_switch + long_name = surface layer evaporation switch + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_elflx] + standard_name = kinematic_surface_latent_heat_flux + long_name = kinematic surface latent heat flux + units = m s-1 kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1u] + standard_name = weight_for_momentum_at_viscous_sublayer_top + long_name = Weight for momentum at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1t] + standard_name = weight_for_potental_temperature_at_viscous_sublayer_top + long_name = Weight for potental temperature at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1q] + standard_name = weight_for_specific_humidity_at_viscous_sublayer_top + long_name = Weight for Specfic Humidity at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[kpbl] + standard_name = vertical_index_at_top_of_atmosphere_boundary_layer + long_name = PBL top model level index + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[kinver] + standard_name = index_of_highest_temperature_inversion + long_name = index of highest temperature inversion + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[garea] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[snowd] + standard_name = surface_snow_thickness_water_equivalent + long_name = water equivalent snow depth over land + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length in cm + units = cm + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + 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_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dqdt] + standard_name = tendency_of_vertically_diffused_tracer_concentration + long_name = updated tendency of the tracers PBL vertical diff + units = kg kg-1 s-1 + dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) + type = real + kind = kind_phys + intent = inout + optional = F +[dusfc] + standard_name = instantaneous_surface_x_momentum_flux + long_name = x momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc] + standard_name = instantaneous_surface_y_momentum_flux + long_name = y momentum flux + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtsfc] + standard_name = instantaneous_surface_upward_sensible_heat_flux + long_name = surface upward sensible heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dqsfc] + standard_name = instantaneous_surface_upward_latent_heat_flux + long_name = surface upward latent heat flux + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dkt] + standard_name = atmosphere_heat_diffusivity + long_name = diffusivity for heat + units = m2 s-1 + dimensions = (horizontal_dimension,vertical_dimension_minus_one) + type = real + kind = kind_phys + intent = out + optional = F +[xkzm_m] + standard_name = atmosphere_momentum_diffusivity_background + long_name = background value of momentum diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_h] + standard_name = atmosphere_heat_diffusivity_background + long_name = background value of heat diffusivity + units = m2 s-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[xkzm_s] + standard_name = diffusivity_background_sigma_level + long_name = sigma level threshold for background diffusivity + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[gamt] + standard_name = countergradient_mixing_term_for_temperature + long_name = countergradient mixing term for temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gamq] + standard_name = countergradient_mixing_term_for_water_vapor + long_name = countergradient mixing term for water vapor + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 2d8399d90..219130374 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -15,100 +15,7 @@ end subroutine myjsfc_wrapper_finalize !> \brief This scheme (1) performs pre-myjsfc work, (20 runs the myj sfc layer scheme, and (3) performs post-myjsfc work #if 0 !! \section arg_table_myjsfc_wrapper_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------|-------------------------------------------------------|---------------|------|-------------|-----------|--------|----------| -!! | restart | flag_for_restart | flag for restart (warmstart) or coldstart | flag | 0 | logical | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | levs | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | -!! | ntke | index_for_turbulent_kinetic_energy | tracer index for turbulent kinetic energy | index | 0 | integer | | in | F | -!! | ntcw | index_for_liquid_cloud_condensate | cloud condensate index in tracer array | index | 0 | integer | | in | F | -!! | ntiw | index_for_ice_cloud_condensate | tracer index for ice water | index | 0 | integer | | in | F | -!! | ntrw | index_for_rain_water | tracer index for rain water | index | 0 | integer | | in | F | -!! | ntsw | index_for_snow_water | tracer index for snow water | index | 0 | integer | | in | F | -!! | ntgl | index_for_graupel | tracer index for graupel | index | 0 | integer | | in | F | -!! | iter | ccpp_loop_counter | loop counter for subcycling loops in CCPP | index | 0 | integer | | in | F | -!! | flag_iter | flag_for_iteration | flag for iteration | flag | 1 | logical | | in | F | -!! | ugrs | x_wind | x component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | vgrs | y_wind | y component of layer wind | m s-1 | 2 | real | kind_phys | in | F | -!! | tgrs | air_temperature | layer mean air temperature | K | 2 | real | kind_phys | in | F | -!! | qgrs | tracer_concentration | model layer mean tracer concentration | kg kg-1 | 3 | real | kind_phys | in | F | -!! | prsl | air_pressure | mean layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | -!! | prsik_1 | dimensionless_exner_function_at_lowest_model_interface | dimensionless Exner function at lowest model interface| none | 1 | real | kind_phys | in | F | -!! | prslk_1 | dimensionless_exner_function_at_lowest_model_layer | dimensionless Exner function at lowest model layer | none | 1 | real | kind_phys | in | F | -!! | tsfc | surface_skin_temperature | surface temperature | K | 1 | real | kind_phys | in | F | -!! | qsfc | surface_specific_humidity | surface air saturation specific humidity | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_qsfc | surface_specific_humidity_for_MYJ_schemes | surface air saturation specific humidity for MYJ schem| kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_thz0 | potential_temperature_at_viscous_sublayer_top | potential temperat at viscous sublayer top over water | K | 1 | real | kind_phys | inout | F | -!! | phy_myj_qz0 | specific_humidity_at_viscous_sublayer_top | specific humidity at_viscous sublayer top over water | kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_uz0 | u_wind_component_at_viscous_sublayer_top | u wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_vz0 | v_wind_component_at_viscous_sublayer_top | v wind component at viscous sublayer top over water | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_z0base | baseline_surface_roughness_length | baseline surface roughness length for momentum in mete| m | 1 | real | kind_phys | inout | F | -!! | phy_myj_akhs | heat_exchange_coefficient_for_MYJ_schemes | surface heat exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_akms | momentum_exchange_coefficient_for_MYJ_schemes | surface momentum exchange_coefficient for MYJ schemes | m s-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_chkqlm | surface_layer_evaporation_switch | surface layer evaporation switch | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_elflx | kinematic_surface_latent_heat_flux | kinematic surface latent heat flux | m s-1 kg kg-1 | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1u | weight_for_momentum_at_viscous_sublayer_top | Weight for momentum at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1t | weight_for_potental_temperature_at_viscous_sublayer_top | Weight for potental temperature at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | phy_myj_a1q | weight_for_specific_humidity_at_viscous_sublayer_top | Weight for Specfic Humidity at viscous layer top | none | 1 | real | kind_phys | inout | F | -!! | pblh | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | inout | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | zorl | surface_roughness_length | surface roughness length | cm | 1 | real | kind_phys | in | F | -!! | ustar | surface_friction_velocity | boundary layer parameter | m s-1 | 1 | real | kind_phys | inout | F | -!! | rib | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | inout | F | -!! | cm | surface_drag_coefficient_for_momentum_in_air | surface exchange coeff for momentum | none | 1 | real | kind_phys | inout | F | -!! | ch | surface_drag_coefficient_for_heat_and_moisture_in_air | surface exchange coeff heat & moisture | none | 1 | real | kind_phys | inout | F | -!! | stress | surface_wind_stress | surface wind stress | m2 s-2 | 1 | real | kind_phys | in | F | -!! | ffm | Monin_Obukhov_similarity_function_for_momentum | Monin_Obukhov similarity function for momentum | none | 1 | real | kind_phys | inout | F | -!! | ffh | Monin_Obukhov_similarity_function_for_heat | Monin_Obukhov similarity function for heat | none | 1 | real | kind_phys | inout | F | -!! | fm10 | Monin_Obukhov_similarity_function_for_momentum_at_10m | Monin_Obukhov similarity parameter for momentum at 10m| none | 1 | real | kind_phys | inout | F | -!! | fh2 | Monin_Obukhov_similarity_function_for_heat_at_2m | Monin_Obukhov similarity parameter for heat at 2m | none | 1 | real | kind_phys | inout | F | -!! | landfrac | land_area_fraction | fraction of horizontal grid area occupied by land | frac | 1 | real | kind_phys | inout | F | -!! | lakefrac | lake_area_fraction | fraction of horizontal grid area occupied by lake | frac | 1 | real | kind_phys | inout | F | -!! | oceanfrac | sea_area_fraction | fraction of horizontal grid area occupied by ocean | frac | 1 | real | kind_phys | inout | F | -!! | fice | sea_ice_concentration | ice fraction over open water | frac | 1 | real | kind_phys | in | F | -!! | z0rl_ocn | surface_roughness_length_over_ocean_interstitial | surface roughness length over ocean (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | z0rl_lnd | surface_roughness_length_over_land_interstitial | surface roughness length over land (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | z0rl_ice | surface_roughness_length_over_ice_interstitial | surface roughness length over ice (interstitial) | cm | 1 | real | kind_phys | inout | F | -!! | ustar_ocn | surface_friction_velocity_over_ocean | surface friction velocity over ocean | m s-1 | 1 | real | kind_phys | inout | F | -!! | ustar_lnd | surface_friction_velocity_over_land | surface friction velocity over land | m s-1 | 1 | real | kind_phys | inout | F | -!! | ustar_ice | surface_friction_velocity_over_ice | surface friction velocity over ice | m s-1 | 1 | real | kind_phys | inout | F | -!! | cm_ocn | surface_drag_coefficient_for_momentum_in_air_over_ocean | surface exchange coeff for momentum over ocean | none | 1 | real | kind_phys | inout | F | -!! | cm_lnd | surface_drag_coefficient_for_momentum_in_air_over_land | surface exchange coeff for momentum over land | none | 1 | real | kind_phys | inout | F | -!! | cm_ice | surface_drag_coefficient_for_momentum_in_air_over_ice | surface exchange coeff for momentum over ice | none | 1 | real | kind_phys | inout | F | -!! | ch_ocn | surface_drag_coefficient_for_heat_and_moisture_in_air_over_ocean | surface exchange coeff heat & moisture over ocean | none | 1 | real | kind_phys | inout | F | -!! | ch_lnd | surface_drag_coefficient_for_heat_and_moisture_in_air_over_land | surface exchange coeff heat & moisture over land | none | 1 | real | kind_phys | inout | F | -!! | ch_ice | surface_drag_coefficient_for_heat_and_moisture_in_air_over_ice | surface exchange coeff heat & moisture over ice | none | 1 | real | kind_phys | inout | F | -!! | rb_ocn | bulk_richardson_number_at_lowest_model_level_over_ocean | bulk Richardson number at the surface over ocean | none | 1 | real | kind_phys | inout | F | -!! | rb_lnd | bulk_richardson_number_at_lowest_model_level_over_land | bulk Richardson number at the surface over land | none | 1 | real | kind_phys | inout | F | -!! | rb_ice | bulk_richardson_number_at_lowest_model_level_over_ice | bulk Richardson number at the surface over ice | none | 1 | real | kind_phys | inout | F | -!! | stress_ocn | surface_wind_stress_over_ocean | surface wind stress over ocean | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | stress_lnd | surface_wind_stress_over_land | surface wind stress over land | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | stress_ice | surface_wind_stress_over_ice | surface wind stress over ice | m2 s-2 | 1 | real | kind_phys | inout | F | -!! | fm_ocn | Monin_Obukhov_similarity_function_for_momentum_over_ocean | Monin-Obukhov similarity funct for momentum over ocean| none | 1 | real | kind_phys | inout | F | -!! | fm_lnd | Monin_Obukhov_similarity_function_for_momentum_over_land | Monin-Obukhov similarity funct for momentum over land | none | 1 | real | kind_phys | inout | F | -!! | fm_ice | Monin_Obukhov_similarity_function_for_momentum_over_ice | Monin-Obukhov similarity funct for momentum over ice | none | 1 | real | kind_phys | inout | F | -!! | fh_ocn | Monin_Obukhov_similarity_function_for_heat_over_ocean | Monin-Obukhov similarity function for heat over ocean | none | 1 | real | kind_phys | inout | F | -!! | fh_lnd | Monin_Obukhov_similarity_function_for_heat_over_land | Monin-Obukhov similarity function for heat over land | none | 1 | real | kind_phys | inout | F | -!! | fh_ice | Monin_Obukhov_similarity_function_for_heat_over_ice | Monin-Obukhov similarity function for heat over ice | none | 1 | real | kind_phys | inout | F | -!! | fm10_ocn | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean | Monin-Obukhov parameter for momentum at 10m over ocean| none | 1 | real | kind_phys | inout | F | -!! | fm10_lnd | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_land | Monin-Obukhov parameter for momentum at 10m over land | none | 1 | real | kind_phys | inout | F | -!! | fm10_ice | Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ice | Monin-Obukhov parameter for momentum at 10m over ice | none | 1 | real | kind_phys | inout | F | -!! | fh2_ocn | Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean | Monin-Obukhov parameter for heat at 2m over ocean | none | 1 | real | kind_phys | inout | F | -!! | fh2_lnd | Monin_Obukhov_similarity_function_for_heat_at_2m_over_land | Monin-Obukhov parameter for heat at 2m over land | none | 1 | real | kind_phys | inout | F | -!! | fh2_ice | Monin_Obukhov_similarity_function_for_heat_at_2m_over_ice | Monin-Obukhov parameter for heat at 2m over ice | none | 1 | real | kind_phys | inout | F | -!! | wind | wind_speed_at_lowest_model_layer | wind speed at lowest model level | m s-1 | 1 | real | kind_phys | out | F | -!! | con_cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | con_rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | me | mpi_rank | current MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! \htmlinclude myjsfc_wrapper_run.html !! #endif !###=================================================================== diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/module_MYJSFC_wrapper.meta new file mode 100644 index 000000000..8100d0b05 --- /dev/null +++ b/physics/module_MYJSFC_wrapper.meta @@ -0,0 +1,814 @@ +[ccpp-arg-table] + name = myjsfc_wrapper_run + type = scheme +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[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 +[ntrac] + standard_name = number_of_tracers + long_name = number of tracers + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntke] + standard_name = index_for_turbulent_kinetic_energy + long_name = tracer index for turbulent kinetic energy + units = index + dimensions = () + type = integer + intent = in + optional = F +[ntcw] + standard_name = index_for_liquid_cloud_condensate + long_name = cloud condensate index in tracer array + 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 +[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 +[ntgl] + standard_name = index_for_graupel + long_name = tracer index for graupel + units = index + dimensions = () + type = integer + intent = in + optional = F +[iter] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_dimension) + type = logical + intent = in + optional = F +[ugrs] + standard_name = x_wind + long_name = x component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[vgrs] + standard_name = y_wind + long_name = y component of layer wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tgrs] + standard_name = air_temperature + long_name = layer mean air temperature + units = K + dimensions = (horizontal_dimension,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_dimension,vertical_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = air pressure at model layer interfaces + units = Pa + dimensions = (horizontal_dimension,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_dimension,vertical_dimension_plus_one) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[tsfc] + standard_name = surface_skin_temperature + long_name = surface temperature + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[qsfc] + standard_name = surface_specific_humidity + long_name = surface air saturation specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qsfc] + standard_name = surface_specific_humidity_for_MYJ_schemes + long_name = surface air saturation specific humidity for MYJ schem + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_thz0] + standard_name = potential_temperature_at_viscous_sublayer_top + long_name = potential temperat at viscous sublayer top over water + units = K + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_qz0] + standard_name = specific_humidity_at_viscous_sublayer_top + long_name = specific humidity at_viscous sublayer top over water + units = kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_uz0] + standard_name = u_wind_component_at_viscous_sublayer_top + long_name = u wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_vz0] + standard_name = v_wind_component_at_viscous_sublayer_top + long_name = v wind component at viscous sublayer top over water + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_z0base] + standard_name = baseline_surface_roughness_length + long_name = baseline surface roughness length for momentum in mete + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akhs] + standard_name = heat_exchange_coefficient_for_MYJ_schemes + long_name = surface heat exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_akms] + standard_name = momentum_exchange_coefficient_for_MYJ_schemes + long_name = surface momentum exchange_coefficient for MYJ schemes + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_chkqlm] + standard_name = surface_layer_evaporation_switch + long_name = surface layer evaporation switch + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_elflx] + standard_name = kinematic_surface_latent_heat_flux + long_name = kinematic surface latent heat flux + units = m s-1 kg kg-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1u] + standard_name = weight_for_momentum_at_viscous_sublayer_top + long_name = Weight for momentum at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1t] + standard_name = weight_for_potental_temperature_at_viscous_sublayer_top + long_name = Weight for potental temperature at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[phy_myj_a1q] + standard_name = weight_for_specific_humidity_at_viscous_sublayer_top + long_name = Weight for Specfic Humidity at viscous layer top + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pblh] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[zorl] + standard_name = surface_roughness_length + long_name = surface roughness length + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ustar] + standard_name = surface_friction_velocity + long_name = boundary layer parameter + units = m s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rib] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm] + standard_name = surface_drag_coefficient_for_momentum_in_air + long_name = surface exchange coeff for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch] + standard_name = surface_drag_coefficient_for_heat_and_moisture_in_air + long_name = surface exchange coeff heat & moisture + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress] + standard_name = surface_wind_stress + long_name = surface wind stress + units = m2 s-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[ffm] + standard_name = Monin_Obukhov_similarity_function_for_momentum + long_name = Monin_Obukhov similarity function for momentum + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ffh] + standard_name = Monin_Obukhov_similarity_function_for_heat + long_name = Monin_Obukhov similarity function for heat + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension) + type = real + 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 = inout + optional = F +[lakefrac] + standard_name = lake_area_fraction + long_name = fraction of horizontal grid area occupied by lake + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fice] + standard_name = sea_ice_concentration + long_name = ice fraction over open water + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[z0rl_ocn] + standard_name = surface_roughness_length_over_ocean_interstitial + long_name = surface roughness length over ocean (interstitial) + units = cm + dimensions = (horizontal_dimension) + 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 (interstitial) + units = cm + dimensions = (horizontal_dimension) + 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 (interstitial) + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ustar_ocn] + standard_name = surface_friction_velocity_over_ocean + long_name = surface friction velocity over ocean + units = m s-1 + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[cm_ocn] + standard_name = surface_drag_coefficient_for_momentum_in_air_over_ocean + long_name = surface exchange coeff for momentum over ocean + units = none + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ch_ocn] + 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_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[rb_ocn] + 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_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[stress_ocn] + standard_name = surface_wind_stress_over_ocean + long_name = surface wind stress over ocean + units = m2 s-2 + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_ocean + long_name = Monin-Obukhov similarity funct for momentum over ocean + units = none + dimensions = (horizontal_dimension) + 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 funct for momentum over land + units = none + dimensions = (horizontal_dimension) + 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 funct for momentum over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_over_ocean + long_name = Monin-Obukhov similarity function for heat over ocean + units = none + dimensions = (horizontal_dimension) + 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_dimension) + 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_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fm10_ocn] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_ocean + long_name = Monin-Obukhov parameter for momentum at 10m over ocean + units = none + dimensions = (horizontal_dimension) + 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 parameter for momentum at 10m over land + units = none + dimensions = (horizontal_dimension) + 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 parameter for momentum at 10m over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[fh2_ocn] + standard_name = Monin_Obukhov_similarity_function_for_heat_at_2m_over_ocean + long_name = Monin-Obukhov parameter for heat at 2m over ocean + units = none + dimensions = (horizontal_dimension) + 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 parameter for heat at 2m over land + units = none + dimensions = (horizontal_dimension) + 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 parameter for heat at 2m over ice + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + 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_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[con_rd] + standard_name = gas_constant_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F From 268f9a54f8611854dc7158102d4f3d2327144016 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 13 Sep 2019 16:34:39 -0600 Subject: [PATCH 23/36] physics/GFS_time_vary_pre.fv3.F90: trim trailing whitespaces --- physics/GFS_time_vary_pre.fv3.F90 | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 8f146de92..46284a1bb 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -30,7 +30,7 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) errflg = 0 if (is_initialized) return - + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () @@ -72,7 +72,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & use machine, only: kind_phys implicit none - + integer, intent(in) :: idate(4) integer, intent(in) :: jdat(1:8), idat(1:8) integer, intent(in) :: lsm, lsm_noahmp, & @@ -80,21 +80,21 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp - + integer, intent(out) :: kdt, yearlen, ipt logical, intent(out) :: lprnt, lssav, lsswr, & lslwr real(kind=kind_phys), intent(out) :: sec, phour, zhour, & fhour, julian, solhr - + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) - - integer :: iw3jdn + + integer :: iw3jdn integer :: jd0, jd1 real :: fjd @@ -120,14 +120,14 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & zhour = phour fhour = (sec + dtp)/con_hr kdt = nint((sec + dtp)/dtp) - + if(lsm == lsm_noahmp) then - !GJF* These calculations were originally in GFS_physics_driver.F90 for - ! NoahMP. They were moved to this routine since they only depends - ! on time (not space). Note that this code is included as-is from - ! GFS_physics_driver.F90, but it may be simplified by using more - ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day - ! of year and W3DIFDAT to determine the integer number of days in + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depend + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in ! a given year). *GJF ! Julian day calculation (fcst day of the year) ! we need yearln and julian to @@ -140,7 +140,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 julian = float(jd1-jd0) + fjd - + ! ! Year length ! @@ -158,7 +158,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & endif endif endif - + ipt = 1 lprnt = .false. lssav = .true. From 26ed03832a92345201157096f7edbc6bb4f8960e Mon Sep 17 00:00:00 2001 From: climbfuji Date: Mon, 16 Sep 2019 15:33:45 -0600 Subject: [PATCH 24/36] physics/GFS_phys_time_vary.fv3.F90: disable calculation of snocvr in CCPP (do in FV3-IPD) to avoid b4b issues when 32BIT=Y --- physics/GFS_phys_time_vary.fv3.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 2d97e6bf2..2b79d6883 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -22,9 +22,11 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol - + +#if 0 !--- variables needed for calculating 'sncovr' use namelist_soilveg, only: salp_data, snupx +#endif implicit none @@ -326,7 +328,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys use GFS_typedefs, only: GFS_control_type, GFS_data_type - + implicit none ! Interface variables @@ -496,7 +498,8 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, enddo endif endif - + +#if 0 !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) if (first_time_step) then if (nint(Data(1)%Sfcprop%sncovr(1)) == -9999) then @@ -519,6 +522,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, enddo endif endif +#endif end subroutine GFS_phys_time_vary_run !> @} From d98248aad15ebeb9f3ba84e070be4b1ad543bc20 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:46:17 -0600 Subject: [PATCH 25/36] CMakeLists.txt: compile ./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 with default double precision --- CMakeLists.txt | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bfcceebc6..d34b491f8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -115,7 +115,7 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-ffree-line-length-none -fdefault-real-8 -ffree-form") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") - + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-fdefault-real-8 -fdefault-double-8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) @@ -167,6 +167,8 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 + ./physics/module_SF_JSFC.F90 + ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files @@ -265,6 +267,8 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") SET_SOURCE_FILES_PROPERTIES(./physics/mersenne_twister.f PROPERTIES COMPILE_FLAGS "-r8 -ftz") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-extend-source 132 -r8 -free") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8") endif (PROJECT STREQUAL "CCPP-FV3") elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) @@ -273,6 +277,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "PGI") SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_water_prop.f90 PROPERTIES COMPILE_FLAGS "-r8 -Mfree") SET_SOURCE_FILES_PROPERTIES(./physics/aer_cloud.F ./physics/wv_saturation.F ./physics/cldwat2m_micro.F ./physics/surface_perturbation.F90 PROPERTIES COMPILE_FLAGS "-r8") SET_SOURCE_FILES_PROPERTIES(./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8") + SET_SOURCE_FILES_PROPERTIES(./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8") if (PROJECT STREQUAL "CCPP-FV3") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) From 806de330f2e8cda7bfa2e6ed4a6cc7753e3da27b Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:47:52 -0600 Subject: [PATCH 26/36] physics/module_BL_MYJPBL.F90, physics/module_SF_JSFC.F90, physics/module_MYJSFC_wrapper.F90: use double precision floats, remove trailing whitespaces --- physics/module_BL_MYJPBL.F90 | 153 +++++++++++++++--------------- physics/module_MYJSFC_wrapper.F90 | 23 +++-- physics/module_SF_JSFC.F90 | 7 +- 3 files changed, 92 insertions(+), 91 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index 6f455221b..af7967ebf 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -24,7 +24,7 @@ MODULE MODULE_BL_MYJPBL ! integer,parameter :: idouble=selected_int_kind(r=18) ! integer,parameter :: single=selected_real_kind(p=6,r=37) ! integer,parameter :: double=selected_real_kind(p=13,r=200) - + ! integer,parameter:: & ! klog=4 & ! ,kint=isingle & @@ -39,7 +39,8 @@ MODULE MODULE_BL_MYJPBL integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & @@ -177,7 +178,7 @@ MODULE MODULE_BL_MYJPBL REAL(KIND=KFPT),DIMENSION(1:ITBL),PRIVATE,SAVE:: & STHE & ! RANGE FOR EQUIVALENT POTENTIAL TEMPERATURE -,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE +,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE REAL(KIND=KFPT),DIMENSION(1:JTBL),PRIVATE,SAVE:: & QS0 & ! BASE FOR SATURATION SPECIFIC HUMIDITY @@ -960,7 +961,7 @@ SUBROUTINE MIXLEN & if( & (q2(k).gt.epsq2(k)) .and. & (q2(k)*cubry.gt.(dz*wcon*rsqdt)**2) & - ) then + ) then ! DTHV=(THE(K)-THE(K+1))+DTHV ! @@ -1119,7 +1120,7 @@ SUBROUTINE PRODQ2 & !********************************************************************** !---------------------------------------------------------------------- ! - + ! IFLAG=1 main_integration: DO K=1,LMH-1 @@ -1149,7 +1150,7 @@ SUBROUTINE PRODQ2 & ! & .OR.(EQOL2<=EPS2)).and.IFLAG.EQ.1)THEN ! ! if(ntsd.eq.23.and.me.eq.76.and.I.eq.32)then -! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL +! print*,'no turb=',K,GML,GHL,EPSTRB,EPSGH,REQU,EQOL2,EPS2,GML/GHL ! end if !---------------------------------------------------------------------- !*** NO TURBULENCE @@ -2075,7 +2076,7 @@ SUBROUTINE TABLETT !----------------------------------------------------------------------- ENDSUBROUTINE TABLETT !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) + SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) ! ****************************************************************** ! * * ! * THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE * @@ -2102,80 +2103,80 @@ SUBROUTINE SPLINE(JTBL,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) ! ****************************************************************** IMPLICIT REAL(KIND=KFPT)(A-H,O-Z),INTEGER(KIND=KINT)(I-N) !----------------------------------------------------------------------- - DIMENSION & - XOLD(JTBL),YOLD(JTBL),Y2(JTBL),P(JTBL),Q(JTBL) & - ,XNEW(JTBL),YNEW(JTBL) + DIMENSION & + XOLD(JTBL),YOLD(JTBL),Y2(JTBL),P(JTBL),Q(JTBL) & + ,XNEW(JTBL),YNEW(JTBL) !----------------------------------------------------------------------- - NOLDM1=NOLD-1 -! - DXL=XOLD(2)-XOLD(1) - DXR=XOLD(3)-XOLD(2) - DYDXL=(YOLD(2)-YOLD(1))/DXL - DYDXR=(YOLD(3)-YOLD(2))/DXR - RTDXC=.5/(DXL+DXR) -! - P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR -! - IF(NOLD.EQ.3) GO TO 700 + NOLDM1=NOLD-1 +! + DXL=XOLD(2)-XOLD(1) + DXR=XOLD(3)-XOLD(2) + DYDXL=(YOLD(2)-YOLD(1))/DXL + DYDXR=(YOLD(3)-YOLD(2))/DXR + RTDXC=.5/(DXL+DXR) +! + P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) + Q(1)=-RTDXC*DXR +! + IF(NOLD.EQ.3) GO TO 700 !----------------------------------------------------------------------- - K=3 -! - 100 DXL=DXR - DYDXL=DYDXR - DXR=XOLD(K+1)-XOLD(K) - DYDXR=(YOLD(K+1)-YOLD(K))/DXR - DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) -! - P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR -! - K=K+1 - IF(K.LT.NOLD) GO TO 100 + K=3 +! + 100 DXL=DXR + DYDXL=DYDXR + DXR=XOLD(K+1)-XOLD(K) + DYDXR=(YOLD(K+1)-YOLD(K))/DXR + DXC=DXL+DXR + DEN=1./(DXL*Q(K-2)+DXC+DXC) +! + P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) + Q(K-1)=-DEN*DXR +! + K=K+1 + IF(K.LT.NOLD) GO TO 100 !----------------------------------------------------------------------- - 700 K=NOLDM1 -! - 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) -! - K=K-1 - IF(K.GT.1) GO TO 200 + 700 K=NOLDM1 +! + 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) +! + K=K-1 + IF(K.GT.1) GO TO 200 !----------------------------------------------------------------------- - K1=1 -! - 300 XK=XNEW(K1) -! - DO 400 K2=2,NOLD - IF(XOLD(K2).LE.XK) GO TO 400 - KOLD=K2-1 - GO TO 450 - 400 CONTINUE - YNEW(K1)=YOLD(NOLD) - GO TO 600 -! - 450 IF(K1.EQ.1) GO TO 500 - IF(K.EQ.KOLD) GO TO 550 -! - 500 K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) -! - 550 X=XK-XOLD(K) - XSQ=X*X -! - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) -! - 600 K1=K1+1 - IF(K1.LE.NNEW) GO TO 300 + K1=1 +! + 300 XK=XNEW(K1) +! + DO 400 K2=2,NOLD + IF(XOLD(K2).LE.XK) GO TO 400 + KOLD=K2-1 + GO TO 450 + 400 CONTINUE + YNEW(K1)=YOLD(NOLD) + GO TO 600 +! + 450 IF(K1.EQ.1) GO TO 500 + IF(K.EQ.KOLD) GO TO 550 +! + 500 K=KOLD +! + Y2K=Y2(K) + Y2KP1=Y2(K+1) + DX=XOLD(K+1)-XOLD(K) + RDX=1./DX +! + AK=.1666667*RDX*(Y2KP1-Y2K) + BK=.5*Y2K + CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) +! + 550 X=XK-XOLD(K) + XSQ=X*X +! + YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) +! + 600 K1=K1+1 + IF(K1.LE.NNEW) GO TO 300 !----------------------------------------------------------------------- - ENDSUBROUTINE SPLINE + ENDSUBROUTINE SPLINE !----------------------------------------------------------------------- ! END MODULE MODULE_BL_MYJPBL diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 219130374..917e22599 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -1,5 +1,5 @@ !> \file module_myjsfc_wrapper.F90 -!! Contains all of the code related to running the MYJ surface layer scheme +!! Contains all of the code related to running the MYJ surface layer scheme MODULE myjsfc_wrapper @@ -13,11 +13,9 @@ end subroutine myjsfc_wrapper_finalize !! !> \brief This scheme (1) performs pre-myjsfc work, (20 runs the myj sfc layer scheme, and (3) performs post-myjsfc work -#if 0 !! \section arg_table_myjsfc_wrapper_run Argument Table !! \htmlinclude myjsfc_wrapper_run.html !! -#endif !###=================================================================== SUBROUTINE myjsfc_wrapper_run( & & restart, & @@ -48,18 +46,19 @@ SUBROUTINE myjsfc_wrapper_run( & & fh2_ocn, fh2_lnd, fh2_ice, & ! intent(inout) & wind, con_cp, con_g, con_rd, & & me, lprnt, errmsg, errflg ) ! intent(inout) -! +! use machine, only : kind_phys use MODULE_SF_JSFC, only: JSFC_INIT,JSFC -!------------------------------------------------------------------- +!------------------------------------------------------------------- implicit none -!------------------------------------------------------------------- +!------------------------------------------------------------------- integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision ! ! --- constant parameters: @@ -82,7 +81,7 @@ SUBROUTINE myjsfc_wrapper_run( & integer, intent(out) :: errflg !MYJ-1D - integer,intent(in) :: im, ix, levs + integer,intent(in) :: im, ix, levs integer,intent(in) :: kdt, iter, me integer,intent(in) :: ntrac,ntke,ntcw,ntiw,ntrw,ntsw,ntgl logical,intent(in) :: restart, lprnt @@ -143,9 +142,9 @@ SUBROUTINE myjsfc_wrapper_run( & & cw, dz_myj, pmid, q2, exner real(kind=kfpt), dimension(im,levs+1) :: pint real(kind=kfpt),dimension(im) :: & - & cm1,ch1,stress1,ffm1,ffh1,wind1,ffm10,ffh2 + & cm1,ch1,stress1,ffm1,ffh1,wind1,ffm10,ffh2 ! real(kind=kind_phys), dimension(im,levs,ntrac) :: & -! & qgrs_myj +! & qgrs_myj ! Initialize CCPP error handling variables errmsg = '' @@ -230,7 +229,7 @@ SUBROUTINE myjsfc_wrapper_run( & dz_myj(i,k) = (phii(i,k1+1)-phii(i,k1)) * g_inv enddo enddo - + if (lprnt1) then if(me==0.and.ntsd.lt.2)then k=63 @@ -302,7 +301,7 @@ SUBROUTINE myjsfc_wrapper_run( & & ,1,im,1,1,1,levs & & ,1,im,1,1,1,levs) end if - + call JSFC(flag_iter,iter,me & & ,ntsd,epsq2,sfcz,dz_myj & & ,pmid,pint,th_myj,t_myj,q_myj,cw & diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 0c79f8de1..76a9d1fa7 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -38,7 +38,8 @@ MODULE MODULE_SF_JSFC integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision ! PRIVATE @@ -92,7 +93,7 @@ MODULE MODULE_SF_JSFC !----------------------------------------------------------------------- INTEGER, PARAMETER :: KZTM=10001,KZTM2=KZTM-2 ! - REAL(kind=kfpt),PRIVATE,SAVE :: & + REAL(kind=kfpt),PRIVATE,SAVE :: & DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2 ! REAL(kind=kfpt),DIMENSION(KZTM),PRIVATE,SAVE :: & @@ -362,7 +363,7 @@ SUBROUTINE JSFC(FLAG_ITER,ITER,ME & ULOW=UK(LMH) VLOW=VK(LMH) ZSL=(ZHK(LMH)-ZHK(LMH+1))*0.5 -! if(me.eq.0)print*,'ZSL,ZHK(LMH),ZHK(LMH+1,LMH=',ZSL,ZHK(LMH),ZHK(LMH+1),LMH +! if(me.eq.0)print*,'ZSL,ZHK(LMH),ZHK(LMH+1,LMH=',ZSL,ZHK(LMH),ZHK(LMH+1),LMH APESFC=(PSFC*1.E-5)**CAPPA if(NTSD==0) then TZ0=TSK(I,J) From dceac20e1b563a7c2615284c4dbe97727b3d42ac Mon Sep 17 00:00:00 2001 From: climbfuji Date: Wed, 18 Sep 2019 13:48:26 -0600 Subject: [PATCH 27/36] physics/module_MYJPBL_wrapper.F90: use double precision floats, remove trailing whitespaces, declare local dkt2 array to account for dimension differences --- physics/module_MYJPBL_wrapper.F90 | 58 ++++++++++++++++++------------- 1 file changed, 33 insertions(+), 25 deletions(-) diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index 8114afea4..aad072e42 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -1,5 +1,5 @@ !> \file module_myjpbl_wrapper.F90 -!! Contains all of the code related to running the MYJ PBL scheme +!! Contains all of the code related to running the MYJ PBL scheme MODULE myjpbl_wrapper @@ -36,26 +36,27 @@ SUBROUTINE myjpbl_wrapper_run( & & garea, ustar, cm, ch, wind, & & snowd, zorl, evap, hflx, & & dudt, dvdt, dtdt, dqdt, & - & dusfc,dvsfc,dtsfc,dqsfc, & + & dusfc,dvsfc,dtsfc,dqsfc, & & dkt,xkzm_m, xkzm_h,xkzm_s, gamt,gamq, & & con_cp,con_g,con_rd, & & me, lprnt, errmsg, errflg ) -! +! use machine, only : kind_phys use MODULE_BL_MYJPBL, only: MYJPBL_INIT,MYJPBL -!------------------------------------------------------------------- +!------------------------------------------------------------------- implicit none integer,parameter:: & klog=4 & ! logical variables ,kint=4 & ! integer variables - ,kfpt=4 & ! floating point variables + !,kfpt=4 & ! floating point variables + ,kfpt=8 & ! floating point variables ,kdbl=8 ! double precision -!------------------------------------------------------------------- +!------------------------------------------------------------------- ! --- constant parameters: !For reference ! real , parameter :: karman = 0.4 @@ -63,10 +64,10 @@ SUBROUTINE myjpbl_wrapper_run( & ! real , parameter :: r_d = 287. ! real , parameter :: cp = 7.*r_d/2. ! -! real, parameter :: g = 9.81, r_d=287., cp= 7.*r_d/2. +! real, parameter :: g = 9.81, r_d=287., cp= 7.*r_d/2. ! real, parameter :: rd=r_d, rk=cp/rd ! real, parameter :: elwv=2.501e6, eliv=2.834e6 -! real, parameter :: reliw=eliv/elwv, +! real, parameter :: reliw=eliv/elwv, real, parameter :: xkgdx=25000.,xkzinv=0.15 ! real, parameter :: g_inv=1./con_g, cappa=con_rd/con_cp @@ -104,8 +105,12 @@ SUBROUTINE myjpbl_wrapper_run( & phii, prsi real(kind=kind_phys),dimension(im,levs),intent(in) :: & & ugrs, vgrs, tgrs, prsl +! real(kind=kind_phys),dimension(im,levs),intent(inout) :: & +! dudt, dvdt, dtdt, dkt real(kind=kind_phys),dimension(im,levs),intent(inout) :: & - dudt, dvdt, dtdt, dkt + dudt, dvdt, dtdt + real(kind=kind_phys),dimension(im,levs-1),intent(out) :: & + dkt !MYJ-4D real(kind=kind_phys),dimension(im,levs,ntrac),intent(inout) :: & @@ -135,10 +140,10 @@ SUBROUTINE myjpbl_wrapper_run( & real(kind=kfpt),dimension(im) :: & dusfc1,dvsfc1,dtsfc1,dqsfc1 real(kind=kfpt),dimension(im) :: thlm,qlm - real(kind=kfpt),dimension(im,13) :: phy_f2d_myj + real(kind=kfpt),dimension(im,13) :: phy_f2d_myj real(kind=kfpt), dimension(im,levs) :: xcofh & & ,xkzo,xkzmo - real(kind=kind_phys) :: g, r_d, g_inv, cappa + real(kind=kind_phys) :: g, r_d, g_inv, cappa real(kind=kind_phys) :: thz0, qz0, a1u, a1t, a1q real(kind=kind_phys) :: z0m, aa1u, aa1t, z1uov, z1tox real(kind=kind_phys) :: tmax,tmin,t_myj1 @@ -148,6 +153,7 @@ SUBROUTINE myjpbl_wrapper_run( & & ,rho,qfc1,gdx,xkzm_hx,xkzm_mx,tx1, tx2 ! real(kind=kind_phys), dimension(im,levs,ntrac) :: & ! & qgrs_myj + real(kind=kind_phys),dimension(im,levs) :: dkt2 ! Initialize CCPP error handling variables errmsg = '' @@ -169,11 +175,11 @@ SUBROUTINE myjpbl_wrapper_run( & end if !prep MYJ-only variables - + r_d = con_rd g = con_g - g_inv = 1./con_g - cappa = con_rd/con_cp + g_inv = 1./con_g + cappa = con_rd/con_cp do i=1,im work3(i)=prsik_1(i) / prslk_1(i) @@ -285,20 +291,20 @@ SUBROUTINE myjpbl_wrapper_run( & ! if (xkzo(i,k) .gt. 0.01) then ! epsl(k)=1.0 ! end if - end do + end do epsq2(levs)=epsq2(levs-1) do k = 1, levs k1 = levs-k+1 do i = 1, im - del(i,k) = prsi(i,k1) - prsi (i,k1+1) + del(i,k) = prsi(i,k1) - prsi (i,k1+1) dz_myj(i,k) = (phii(i,k1+1)-phii(i,k1)) * g_inv enddo enddo do i = 1, im wind1(i)=max(wind(i),1.0) - end do + end do if(.not.do_myjsfc)then do i=1,im @@ -433,7 +439,7 @@ SUBROUTINE myjpbl_wrapper_run( & tmax=t_myj(i,k1) i_max=i k_max=k - end if + end if if(tmin.gt.t_myj(i,k1))then tmin=t_myj(i,k1) i_min=i @@ -450,7 +456,7 @@ SUBROUTINE myjpbl_wrapper_run( & ! end if end if - + ct=0. ide=im lm=levs @@ -541,14 +547,14 @@ SUBROUTINE myjpbl_wrapper_run( & ! do k=1,13 ! Tbd%phy_f2d_myj(i,k)=phy_f2d_myj(i,k) ! end do - end do + end do - dkt=0. + dkt2=0. do k=1,levs k1=levs-k+1 do i=1,im -! dkt(i,k)=max(xcofh(i,k1),xkzo(i,k)) - dkt(i,k)=xcofh(i,k1) +! dkt2(i,k)=max(xcofh(i,k1),xkzo(i,k)) + dkt2(i,k)=xcofh(i,k1) end do end do if(ntke.gt.0)then @@ -617,7 +623,7 @@ SUBROUTINE myjpbl_wrapper_run( & (phy_f2d_myj(i,k),k=1,13) print*,'tsk(i),ustar1,z0,pblh_myj,kpbl_myj=', & tsk(i),ustar1(i),z0(i),pblh_myj(i),kpbl_myj(i) - print*,'mixht=',mixht(i) + print*,'mixht=',mixht(i) do k=1,levs print*,'u,v,t=',k,u_myj(i,k),v_myj(i,k), & t_myj(i,k) @@ -634,7 +640,7 @@ SUBROUTINE myjpbl_wrapper_run( & q2(i,k) end do do k=1,levs - print*,'xcofh,el_myj,dkt=',k,xcofh(i,k),el_myj(i,k),dkt(i,k) + print*,'xcofh,el_myj,dkt2=',k,xcofh(i,k),el_myj(i,k),dkt2(i,k) end do end if @@ -777,6 +783,8 @@ SUBROUTINE myjpbl_wrapper_run( & ! print* ! endif + ! External dkt has dimensions (1:im,1:levs-1) + dkt(1:im,1:levs-1) = dkt2(1:im,1:levs-1) END SUBROUTINE myjpbl_wrapper_run From d58c0eadada9ce4edd2c54dd47c9a5d2c97044ad Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 18 Sep 2019 15:55:51 -0600 Subject: [PATCH 28/36] update SCM version of GFS_time_vary_pre.F90 (matches FV3 version except for a comment) --- physics/GFS_time_vary_pre.scm.F90 | 126 ++++++++++++----- physics/GFS_time_vary_pre.scm.meta | 211 ++++++++++++++++++++++++++++- 2 files changed, 297 insertions(+), 40 deletions(-) diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index 790cf0d1a..2fa352710 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -30,7 +30,7 @@ subroutine GFS_time_vary_pre_init (errmsg, errflg) errflg = 0 if (is_initialized) return - + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () @@ -65,20 +65,38 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_run Argument Table !! \htmlinclude GFS_time_vary_pre_run.html !! - subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) + subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & + julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) use machine, only: kind_phys - use GFS_typedefs, only: GFS_control_type implicit none - - type(GFS_control_type), intent(inout) :: Model + + integer, intent(in) :: idate(4) + integer, intent(in) :: jdat(1:8), idat(1:8) + integer, intent(in) :: lsm, lsm_noahmp, & + nsswr, nslwr, me, & + master, nscyc + logical, intent(in) :: debug + real(kind=kind_phys), intent(in) :: dtp + + integer, intent(out) :: kdt, yearlen, ipt + logical, intent(out) :: lprnt, lssav, lsswr, & + lslwr + real(kind=kind_phys), intent(out) :: sec, phour, zhour, & + fhour, julian, solhr + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys real(kind=kind_phys) :: rinc(5) + + integer :: iw3jdn + integer :: jd0, jd1 + real :: fjd ! Initialize CCPP error handling variables errmsg = '' @@ -86,47 +104,87 @@ subroutine GFS_time_vary_pre_run (Model, errmsg, errflg) ! Check initialization status if (.not.is_initialized) then - write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called before GFS_time_vary_pre_init" + write(errmsg,'(*(a))') "Logic error: GFS_time_vary_pre_run called & + &before GFS_time_vary_pre_init" errflg = 1 return end if - !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- jdat is being updated directly inside of the time integration + !--- loop of gmtb_scm.F90 !--- update calendars and triggers rinc(1:5) = 0 - call w3difdat(Model%jdat,Model%idat,4,rinc) - Model%sec = rinc(4) - Model%phour = Model%sec/con_hr + call w3difdat(jdat,idat,4,rinc) + sec = rinc(4) + phour = sec/con_hr !--- set current bucket hour - Model%zhour = Model%phour - Model%fhour = (Model%sec + Model%dtp)/con_hr - Model%kdt = nint((Model%sec + Model%dtp)/Model%dtp) - - Model%ipt = 1 - Model%lprnt = .false. - Model%lssav = .true. + zhour = phour + fhour = (sec + dtp)/con_hr + kdt = nint((sec + dtp)/dtp) + + if(lsm == lsm_noahmp) then + !GJF* These calculations were originally in GFS_physics_driver.F90 for + ! NoahMP. They were moved to this routine since they only depends + ! on time (not space). Note that this code is included as-is from + ! GFS_physics_driver.F90, but it may be simplified by using more + ! NCEP W3 library calls (e.g., see W3DOXDAT, W3FS13 for Julian day + ! of year and W3DIFDAT to determine the integer number of days in + ! a given year). *GJF + ! Julian day calculation (fcst day of the year) + ! we need yearln and julian to + ! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 + ! jdat is changing + ! + + jd1 = iw3jdn(jdat(1),jdat(2),jdat(3)) + jd0 = iw3jdn(jdat(1),1,1) + fjd = float(jdat(5))/24.0 + float(jdat(6))/1440.0 + + julian = float(jd1-jd0) + fjd + + ! + ! Year length + ! + ! what if the integration goes from one year to another? + ! iyr or jyr ? from 365 to 366 or from 366 to 365 + ! + ! is this against model's noleap yr assumption? + if (mod(jdat(1),4) == 0) then + yearlen = 366 + if (mod(jdat(1),100) == 0) then + yearlen = 365 + if (mod(jdat(1),400) == 0) then + yearlen = 366 + endif + endif + endif + endif + + ipt = 1 + lprnt = .false. + lssav = .true. !--- radiation triggers - Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) - Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + lsswr = (mod(kdt, nsswr) == 1) + lslwr = (mod(kdt, nslwr) == 1) !--- allow for radiation to be called on every physics time step, if needed - if (Model%nsswr == 1) Model%lsswr = .true. - if (Model%nslwr == 1) Model%lslwr = .true. + if (nsswr == 1) lsswr = .true. + if (nslwr == 1) lslwr = .true. !--- set the solar hour based on a combination of phour and time initial hour - Model%solhr = mod(Model%phour+Model%idate(1),con_24) - - if ((Model%debug) .and. (Model%me == Model%master)) then - print *,' sec ', Model%sec - print *,' kdt ', Model%kdt - print *,' nsswr ', Model%nsswr - print *,' nslwr ', Model%nslwr - print *,' nscyc ', Model%nscyc - print *,' lsswr ', Model%lsswr - print *,' lslwr ', Model%lslwr - print *,' fhour ', Model%fhour - print *,' phour ', Model%phour - print *,' solhr ', Model%solhr + solhr = mod(phour+idate(1),con_24) + + if ((debug) .and. (me == master)) then + print *,' sec ', sec + print *,' kdt ', kdt + print *,' nsswr ', nsswr + print *,' nslwr ', nslwr + print *,' nscyc ', nscyc + print *,' lsswr ', lsswr + print *,' lslwr ', lslwr + print *,' fhour ', fhour + print *,' phour ', phour + print *,' solhr ', solhr endif end subroutine GFS_time_vary_pre_run diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index c4312790f..3dc91952e 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -45,13 +45,212 @@ [ccpp-arg-table] name = GFS_time_vary_pre_run type = scheme -[Model] - standard_name = GFS_control_type_instance - long_name = Fortran DDT containing FV3-GFS model control parameters - units = DDT +[jdat] + standard_name = forecast_date_and_time + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[idat] + standard_name = date_and_time_at_model_initialization + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in + optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s dimensions = () - type = GFS_control_type - intent = inout + type = real + 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 + units = + dimensions = () + type = integer + intent = in + optional = F +[nslwr] + standard_name = number_of_timesteps_between_longwave_radiation_calls + long_name = number of timesteps between longwave radiation calls + units = + dimensions = () + type = integer + intent = in + optional = F +[idate] + standard_name = date_and_time_at_model_initialization_reordered + long_name = initial date with different size and ordering + units = none + dimensions = (4) + type = integer + intent = in + optional = F +[debug] + standard_name = flag_debug + long_name = control flag for debug + 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 +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[nscyc] + standard_name = number_of_timesteps_between_surface_cycling_calls + long_name = number of timesteps between surface cycling calls + units = + dimensions = () + type = integer + intent = in + optional = F +[sec] + standard_name = seconds_elapsed_since_model_initialization + long_name = seconds elapsed since model initialization + units = s + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[phour] + standard_name = forecast_time_at_previous_timestep + long_name = forecast time at the previous timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[zhour] + standard_name = time_since_diagnostics_zeroed + long_name = time since diagnostics variables have been zeroed + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[fhour] + standard_name = forecast_time + long_name = current forecast time + units = h + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = out + optional = F +[julian] + standard_name = julian_day + long_name = julian day + units = days + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F +[yearlen] + standard_name = number_of_days_in_year + long_name = number of days in a year + units = days + dimensions = () + type = integer + intent = out + optional = F +[ipt] + standard_name = index_for_diagnostic_printout + long_name = horizontal index for point used for diagnostic printout + units = + dimensions = () + type = integer + intent = out + optional = F +[lprnt] + standard_name = flag_print + long_name = control flag for diagnostic print out + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[lslwr] + standard_name = flag_to_calc_lw + long_name = logical flags for lw radiation calls + units = flag + dimensions = () + type = logical + intent = out + optional = F +[solhr] + standard_name = forecast_hour_of_the_day + long_name = time in hours after 00z at the current timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = out optional = F [errmsg] standard_name = ccpp_error_message From 95b887c29503f25b8014048537dad0292fd4c8f0 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 08:00:20 -0600 Subject: [PATCH 29/36] Remove TRANSITION mode --- CMakeLists.txt | 46 -------------------------------- physics/gfdl_cloud_microphys.F90 | 11 -------- physics/gfdl_fv_sat_adj.F90 | 22 --------------- 3 files changed, 79 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index d34b491f8..443d7ea51 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -187,52 +187,6 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Add all of the above files to the list of schemes with special compiler flags list(APPEND SCHEMES_SFX_OPT ./physics/radiation_aerosols.f) - # Force consistent results of math calculations for MG microphysics; - # in Debug/Bitforbit mode; without this flag, the results of the - # intrinsic gamma function are different for the non-CCPP and CCPP - # version (on Theia with Intel 18). Note this is only required for - # the dynamic CCPP build, not for the static CCPP build. - if (TRANSITION) - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I, -no-prec-div with -prec-div, and - # -no-prec-sqrt with -prec-sqrt for certain files for bit-for-bit reproducibility - # with non-CCPP builds. These may go in the future once the CCPP solution is fully accepted. - set(CMAKE_Fortran_FLAGS_LOPT2 ${CMAKE_Fortran_FLAGS_OPT}) - string(REPLACE "-no-prec-div" "-prec-div" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-no-prec-sqrt" "-prec-sqrt" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2" "-axSSE4.2,AVX,CORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT2 - "${CMAKE_Fortran_FLAGS_LOPT2}") - SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 - ./physics/micro_mg3_0.F90 - ./physics/aer_cloud.F - ./physics/cldmacro.F - ./physics/gfdl_fv_sat_adj.F90 - ./physics/module_gfdl_cloud_microphys.F90 - ./physics/sflx.f - ./physics/satmedmfvdif.F - ./physics/cs_conv.F90 - ./physics/gcm_shoc.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT2}") - # Add all of the above files to the list of schemes with special compiler flags - list(APPEND SCHEMES_SFX_OPT ./physics/micro_mg2_0.F90 - ./physics/micro_mg3_0.F90 - ./physics/aer_cloud.F - ./physics/cldmacro.F - ./physics/module_gfdl_cloud_microphys.F90 - ./physics/sflx.f - ./physics/satmedmfvdif.F - ./physics/cs_conv.F90 - ./physics/gcm_shoc.F90 - ./physics/gfdl_fv_sat_adj.F90) - endif (TRANSITION) - # Remove files with special compiler flags from list of files with standard compiler flags list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) # Assign standard compiler flags to all remaining schemes and caps diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 6d907e40a..fcaaa9b94 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -170,9 +170,6 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), dimension(:,:), allocatable :: den real(kind=kind_phys) :: onebg real(kind=kind_phys) :: tem -#ifdef TRANSITION - real(kind=kind_phys), volatile :: volatile_var1, volatile_var2 -#endif ! Initialize CCPP error handling variables errmsg = '' @@ -260,18 +257,10 @@ subroutine gfdl_cloud_microphys_run( & ! calculate fraction of frozen precipitation using unscaled ! values of rain0, ice0, snow0, graupel0 (for bit-for-bit) do i=1,im -#ifdef TRANSITION - volatile_var1 = rain0(i)+snow0(i)+ice0(i)+graupel0(i) - volatile_var2 = snow0(i)+ice0(i)+graupel0(i) - prcp0(i) = volatile_var1 * tem - if ( volatile_var1 * tem > rainmin ) then - sr(i) = volatile_var2 / volatile_var1 -#else prcp0(i) = (rain0(i)+snow0(i)+ice0(i)+graupel0(i)) * tem if ( prcp0(i) > rainmin ) then sr(i) = (snow0(i) + ice0(i) + graupel0(i)) & / (rain0(i) + snow0(i) + ice0(i) + graupel0(i)) -#endif else sr(i) = 0.0 endif diff --git a/physics/gfdl_fv_sat_adj.F90 b/physics/gfdl_fv_sat_adj.F90 index d535ebc91..14b3975f3 100644 --- a/physics/gfdl_fv_sat_adj.F90 +++ b/physics/gfdl_fv_sat_adj.F90 @@ -296,10 +296,6 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, ! Local variables real(kind=kind_dyn), dimension(is:ie,js:je) :: dpln -#ifdef TRANSITION - ! For bit-for-bit reproducibility - real(kind=kind_dyn), volatile :: volatile_var -#endif integer :: kdelz integer :: k, j, i @@ -317,9 +313,6 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, !$OMP ql,qv,te0,fast_mp_consv, & !$OMP hydrostatic,ng,zvir,pkz, & !$OMP akap,te0_2d,ngas,qvi) & -#ifdef TRANSITION -!$OMP private(volatile_var) & -#endif !$OMP private(k,j,i,kdelz,dpln) #endif @@ -351,28 +344,13 @@ subroutine fv_sat_adj_run(mdt, zvir, is, ie, isd, ied, kmp, km, kmdelz, js, je, do j=js,je do i=is,ie #ifdef MOIST_CAPPA -#ifdef TRANSITION - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(cappa(i,j,k)*volatile_var) -#else pkz(i,j,k) = exp(cappa(i,j,k)*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) -#endif -#else -#ifdef TRANSITION -#ifdef MULTI_GASES - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(akap*(virqd(q(i,j,k,1:num_gas))/vicpqd(q(i,j,k,1:num_gas))*volatile_var) -#else - volatile_var = log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)) - pkz(i,j,k) = exp(akap*volatile_var) -#endif #else #ifdef MULTI_GASES pkz(i,j,k) = exp(akap*(virqd(q(i,j,k,1:num_gas))/vicpqd(q(i,j,k,1:num_gas))*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) #else pkz(i,j,k) = exp(akap*log(rrg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k))) #endif -#endif #endif enddo enddo From 3db21442fbdd7ae61779e6768bae8466008bff28 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Fri, 20 Sep 2019 09:48:54 -0600 Subject: [PATCH 30/36] add calculation of snow cover in GFS_phys_time_vary.scm.F90 to match FV3 version; this is ifdefed out and may not be necessary for the SCM --- physics/GFS_phys_time_vary.scm.F90 | 35 ++++++++++++++++++++++++++--- physics/GFS_phys_time_vary.scm.meta | 8 +++++++ 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index 6905b9277..d8ca39ba3 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -15,6 +15,11 @@ module GFS_phys_time_vary use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol +#if 0 + !--- variables needed for calculating 'sncovr' + use namelist_soilveg, only: salp_data, snupx +#endif + implicit none private @@ -220,7 +225,7 @@ end subroutine GFS_phys_time_vary_finalize !> \section arg_table_GFS_phys_time_vary_run Argument Table !! \htmlinclude GFS_phys_time_vary_run.html !! - subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, Diag, errmsg, errflg) + subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, Diag, first_time_step, errmsg, errflg) use mersenne_twister, only: random_setseed, random_number use machine, only: kind_phys @@ -238,6 +243,7 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, type(GFS_sfcprop_type), intent(inout) :: Sfcprop type(GFS_cldprop_type), intent(inout) :: Cldprop type(GFS_diag_type), intent(inout) :: Diag + logical, intent(in) :: first_time_step character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -245,8 +251,8 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys - integer :: i, j, k, iseed, iskip, ix, nb, kdt_rad - real(kind=kind_phys) :: sec_zero + integer :: i, j, k, iseed, iskip, ix, nb, kdt_rad, vegtyp + real(kind=kind_phys) :: sec_zero, rsnow real(kind=kind_phys) :: wrk(1) real(kind=kind_phys) :: rannie(Model%cny) real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) @@ -362,6 +368,29 @@ subroutine GFS_phys_time_vary_run (Grid, Statein, Model, Tbd, Sfcprop, Cldprop, !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED endif endif + +#if 0 + !Calculate sncovr if it was read in but empty (from FV3/io/FV3GFS_io.F90/sfc_prop_restart_read) + if (first_time_step) then + if (nint(Sfcprop%sncovr(1)) == -9999) then + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do ix = 1, Model%blksz(nb) + Sfcprop%sncovr(ix) = 0.0 + if (Sfcprop%slmsk(ix) > 0.001) then + vegtyp = Sfcprop%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Sfcprop%weasd(ix)/snupx(vegtyp) + if (0.001*Sfcprop%weasd(ix) < snupx(vegtyp)) then + Sfcprop%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Sfcprop%sncovr(ix) = 1.0 + endif + endif + enddo + endif + endif +#endif end subroutine GFS_phys_time_vary_run diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 4fc643d29..57a82ecb0 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -133,6 +133,14 @@ type = GFS_diag_type intent = inout optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 5d776f6fda3191dd726b200b7307cbc151ae3318 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 19:58:53 -0600 Subject: [PATCH 31/36] physics/machine.*: add kind_LOGICAL, add metadata for kind_LOGICAL and kind_INTEGER --- physics/machine.F | 2 ++ physics/machine.meta | 12 ++++++++++++ 2 files changed, 14 insertions(+) diff --git a/physics/machine.F b/physics/machine.F index f50a950d7..ea6198c33 100644 --- a/physics/machine.F +++ b/physics/machine.F @@ -20,6 +20,7 @@ module machine &, kind_phys = 8 ,kind_taum=8 & &, kind_grid = 8 & &, kind_REAL = 8 &! used in cmp_comm + &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- #else @@ -34,6 +35,7 @@ module machine &, kind_phys = 4 ,kind_taum=4 & &, kind_grid = 4 & &, kind_REAL = 4 &! used in cmp_comm + &, kind_LOGICAL = 4 & &, kind_INTEGER = 4 ! -,,- #endif diff --git a/physics/machine.meta b/physics/machine.meta index 43fc8770a..d93f50e09 100644 --- a/physics/machine.meta +++ b/physics/machine.meta @@ -19,3 +19,15 @@ units = none dimensions = () type = integer +[kind_LOGICAL] + standard_name = kind_LOGICAL + long_name = definition of kind_LOGICAL + units = none + dimensions = () + type = integer +[kind_INTEGER] + standard_name = kind_INTEGER + long_name = definition of kind_INTEGER + units = none + dimensions = () + type = integer From f7ca0878f2267a87c55fd8bfeba14bc598a4337e Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 20 Sep 2019 19:59:24 -0600 Subject: [PATCH 32/36] Replace internal kind definitions for MYJ SFC/PBL schemes with imports from machine.F --- physics/module_BL_MYJPBL.F90 | 16 ++++++++++------ physics/module_MYJPBL_wrapper.F90 | 20 ++++++++++---------- physics/module_MYJSFC_wrapper.F90 | 17 ++++++++++------- physics/module_SF_JSFC.F90 | 15 +++++++++------ 4 files changed, 39 insertions(+), 29 deletions(-) diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 index af7967ebf..b23e67cb5 100755 --- a/physics/module_BL_MYJPBL.F90 +++ b/physics/module_BL_MYJPBL.F90 @@ -15,6 +15,10 @@ MODULE MODULE_BL_MYJPBL ! ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & ! ,STBOLT,CAPPA + USE machine, only: kfpt => kind_phys, & + kint => kind_INTEGER, & + klog => kind_LOGICAL + !----------------------------------------------------------------------- ! IMPLICIT NONE @@ -36,12 +40,12 @@ MODULE MODULE_BL_MYJPBL ! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' ! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision + ! integer,parameter:: & + ! klog=4 & ! logical variables + ! ,kint=4 & ! integer variables + ! !,kfpt=4 & ! floating point variables + ! ,kfpt=8 & ! floating point variables + ! ,kdbl=8 ! double precision REAL(kind=kfpt),PARAMETER :: A2=17.2693882,A3=273.15,A4=35.86,CP=1004.6 & ,ELIV=2.850e6,ELWV=2.501e6,R_V=461.6 & diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index aad072e42..e28cf5e69 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -3,6 +3,9 @@ MODULE myjpbl_wrapper + USE machine, only: kfpt => kind_phys, & + kind_phys + contains subroutine myjpbl_wrapper_init () @@ -13,11 +16,9 @@ end subroutine myjpbl_wrapper_finalize !! !> \brief This scheme (1) performs pre-myjpbl work, (2) runs the myjpbl, and (3) performs post-myjpbl work -#if 0 !! \section arg_table_myjpbl_wrapper_run Argument Table !! \htmlinclude myjpbl_wrapper_run.html !! -#endif !###=================================================================== SUBROUTINE myjpbl_wrapper_run( & & restart,do_myjsfc, & @@ -42,19 +43,18 @@ SUBROUTINE myjpbl_wrapper_run( & & me, lprnt, errmsg, errflg ) ! - use machine, only : kind_phys use MODULE_BL_MYJPBL, only: MYJPBL_INIT,MYJPBL !------------------------------------------------------------------- implicit none - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision +! integer,parameter:: & +! klog=4 & ! logical variables +! ,kint=4 & ! integer variables +! !,kfpt=4 & ! floating point variables +! ,kfpt=8 & ! floating point variables +! ,kdbl=8 ! double precision !------------------------------------------------------------------- ! --- constant parameters: @@ -121,7 +121,7 @@ SUBROUTINE myjpbl_wrapper_run( & integer :: i_min, i_max, k_min, k_max logical :: lprnt1,lprnt2 - integer (kind=kint) :: ict, ide, lm, me1 + integer :: ict, ide, lm, me1 real(kind=kfpt) :: dt_myj, tem, tem1, tem2, ptem integer,dimension(im) :: kpbl_myj real(kind=kfpt),dimension(1:levs-1):: epsl diff --git a/physics/module_MYJSFC_wrapper.F90 b/physics/module_MYJSFC_wrapper.F90 index 917e22599..1406a99be 100644 --- a/physics/module_MYJSFC_wrapper.F90 +++ b/physics/module_MYJSFC_wrapper.F90 @@ -3,6 +3,9 @@ MODULE myjsfc_wrapper + USE machine, only: kfpt => kind_phys, & + kind_phys + contains subroutine myjsfc_wrapper_init () @@ -47,19 +50,19 @@ SUBROUTINE myjsfc_wrapper_run( & & wind, con_cp, con_g, con_rd, & & me, lprnt, errmsg, errflg ) ! intent(inout) ! - use machine, only : kind_phys + use MODULE_SF_JSFC, only: JSFC_INIT,JSFC !------------------------------------------------------------------- implicit none !------------------------------------------------------------------- - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision +! integer,parameter:: & +! klog=4 & ! logical variables +! ,kint=4 & ! integer variables +! !,kfpt=4 & ! floating point variables +! ,kfpt=8 & ! floating point variables +! ,kdbl=8 ! double precision ! ! --- constant parameters: ! real(kind=kind_phys), parameter :: karman = 0.4 diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 index 76a9d1fa7..8d67a81cd 100755 --- a/physics/module_SF_JSFC.F90 +++ b/physics/module_SF_JSFC.F90 @@ -15,6 +15,9 @@ MODULE MODULE_SF_JSFC ! !----------------------------------------------------------------------- ! + + USE machine, only: kfpt => kind_phys + IMPLICIT NONE ! !----------------------------------------------------------------------- @@ -35,12 +38,12 @@ MODULE MODULE_SF_JSFC ! real (kind=kdbl),parameter :: r8_in=x'fff7ffffffffffff' ! integer(kind=kint),parameter :: i4_in=-999 ! -huge(1) ! - integer,parameter:: & - klog=4 & ! logical variables - ,kint=4 & ! integer variables - !,kfpt=4 & ! floating point variables - ,kfpt=8 & ! floating point variables - ,kdbl=8 ! double precision + ! integer,parameter:: & + ! klog=4 & ! logical variables + ! ,kint=4 & ! integer variables + ! !,kfpt=4 & ! floating point variables + ! ,kfpt=8 & ! floating point variables + ! ,kdbl=8 ! double precision ! PRIVATE ! From 92cc1ef09df83c38b01d4f97936e2ad91ea13398 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Mon, 23 Sep 2019 13:36:41 +0000 Subject: [PATCH 33/36] Adding gsd drag suite to ccpp. --- physics/drag_suite.F90 | 1557 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1557 insertions(+) create mode 100644 physics/drag_suite.F90 diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 new file mode 100644 index 000000000..a8ed0fc1b --- /dev/null +++ b/physics/drag_suite.F90 @@ -0,0 +1,1557 @@ +!> \File drag_suite.F90 +!! This file is the parameterization of orographic gravity wave +!! drag, mountain blocking, and form drag. + +!> This module contains the CCPP-compliant orographic gravity wave +!! drag pre interstitial codes. + module drag_suite_pre + + contains + +!> \section arg_table_drag_suite_pre_init Argument Table +!! + subroutine drag_suite_pre_init() + end subroutine drag_suite_pre_init + +!! \section arg_table_drag_suite_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | +!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | +!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | +!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | +!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine drag_suite_pre_run( & + & im, nmtvr, mntvar, & + & hprime, oc, oa4, clx, theta, & + & sigma, gamma, elvmax, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, nmtvr + real(kind=kind_phys), intent(in) :: mntvar(im,nmtvr) + + real(kind=kind_phys), intent(out) :: & + & hprime(im), oc(im), oa4(im,4), clx(im,4), & + & theta(im), sigma(im), gamma(im), elvmax(im) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (nmtvr == 14) then ! current operational - as of 2014 + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + theta(:) = mntvar(:,11) + gamma(:) = mntvar(:,12) + sigma(:) = mntvar(:,13) + elvmax(:) = mntvar(:,14) + elseif (nmtvr == 10) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = mntvar(:,7) + clx(:,2) = mntvar(:,8) + clx(:,3) = mntvar(:,9) + clx(:,4) = mntvar(:,10) + elseif (nmtvr == 6) then + hprime(:) = mntvar(:,1) + oc(:) = mntvar(:,2) + oa4(:,1) = mntvar(:,3) + oa4(:,2) = mntvar(:,4) + oa4(:,3) = mntvar(:,5) + oa4(:,4) = mntvar(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + hprime = 0 + oc = 0 + oa4 = 0 + clx = 0 + theta = 0 + gamma = 0 + sigma = 0 + elvmax = 0 + endif ! end if_nmtvr + + end subroutine drag_suite_pre_run +!> @} + +! \ingroup GFS_ogwd +! \brief Brief description of the subroutine +! +!> \section arg_table_drag_suite_pre_finalize Argument Table +!! + subroutine drag_suite_pre_finalize() + end subroutine drag_suite_pre_finalize + + end module drag_suite_pre + +!> This module contains the CCPP-compliant orographic gravity wave dray scheme. + module drag_suite + + contains + +!> \section arg_table_drag_suite_init Argument Table +!! + subroutine drag_suite_init() + end subroutine drag_suite_init + +! \defgroup GFS_ogwd GFS Orographic Gravity Wave Drag +!> \defgroup gfs_drag_suite GFS drag_suite Main +!! \brief This subroutine includes orographic gravity wave drag, mountain +!! blocking, and form drag. +!! +!> The time tendencies of zonal and meridional wind are altered to +!! include the effect of mountain induced gravity wave drag from +!! subgrid scale orography including convective breaking, shear +!! breaking and the presence of critical levels. +!! +!! \section arg_table_drag_suite_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | km | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | +!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | inout | F | +!! | u1 | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | +!! | v1 | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | +!! | t1 | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | +!! | q1 | water_vapor_specific_humidity | mid-layer specific humidity of water vapor | kg kg-1 | 2 | real | kind_phys | in | F | +!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | vertical index at top atmospheric boundary layer | index | 1 | integer | | in | F | +!! | prsi | air_pressure_at_interface | interface pressure | Pa | 2 | real | kind_phys | in | F | +!! | del | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | +!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | +!! | prslk | dimensionless_exner_function_at_model_layers | mid-layer Exner function | none | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | interface geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phil | geopotential | mid-layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | +!! | deltim | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | +!! | var | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | +!! | oc1 | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | in | F | +!! | ol4 | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | in | F | +!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | in | F | +!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | in | F | +!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | inout | F | +!! | dtaux2d_ls | x_momentum_tendency_from_large_scale_gwd | x momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_ls | y_momentum_tendency_from_large_scale_gwd | y momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_bl | x_momentum_tendency_from_blocking_drag | x momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_bl | y_momentum_tendency_from_blocking_drag | y momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_ss | x_momentum_tendency_from_small_scale_gwd | x momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_ss | y_momentum_tendency_from_small_scale_gwd | y momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | +!! | dtaux2d_fd | x_momentum_tendency_from_form_drag | x momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dtauy2d_fd | y_momentum_tendency_from_form_drag | y momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | +!! | dusfc | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | dvsfc | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | +!! | dusfc_ls | integrated_x_momentum_flux_from_large_scale_gwd | integrated x momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_ls | integrated_y_momentum_flux_from_large_scale_gwd | integrated y momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_bl | integrated_x_momentum_flux_from_blocking_drag | integrated x momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_bl | integrated_y_momentum_flux_from_blocking_drag | integrated y momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_ss | integrated_x_momentum_flux_from_small_scale_gwd | integrated x momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_ss | integrated_y_momentum_flux_from_small_scale_gwd | integrated y momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | +!! | dusfc_fd | integrated_x_momentum_flux_from_form_drag | integrated x momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | +!! | dvsfc_fd | integrated_y_momentum_flux_from_form_drag | integrated y momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | +!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | +!! | br1 | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | +!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | +!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | +!! | pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | +!! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | +!! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | +!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | +!! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | +!! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | +!! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | +!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | +!! | gwd_opt | gwd_opt | flag to choose gwd scheme | flag | 0 | integer | | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +!> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm +!! -# Calculate subgrid mountain blocking +!! -# Calculate orographic wave drag +!! +!! The NWP model gravity wave drag (GWD) scheme in the GFS has two +!! main components: how the surface stress is computed, and then how +!! that stress is distributed over a vertical column where it may +!! interact with the models momentum. Each of these depends on the +!! large scale environmental atmospheric state and assumptions about +!! the sub-grid scale processes. In Alpert GWD (1987) based on linear, +!! two-dimensional non-rotating, stably stratified flow over a mountain ridge, +!! sub-grid scale gravity wave motions are assumed which propagate away +!! from the mountain. Described in Alpert (1987), the flux measured over +!! a "low level" vertically averaged layer, in the atmosphere defines a base +!! level flux. "Low level" was taken to be the first 1/3 of the troposphere +!! in the 1987 implementation. This choice was meant to encompass a thick +!! low layer for vertical averages of the environmental (large scale) flow +!! quantities. The vertical momentum flux or gravity wave stress in a +!! grid box due to a single mountain is given as in Pierrehumbert, (1987) (PH): +!! +!! \f$ \tau = \frac {\rho \: U^{3}\: G(F_{r})} {\Delta X \; N } \f$ +!! +!! emetic \f$ \Delta X \f$ is a grid increment, N is the Brunt Viasala frequency +!! +!! +!! \f$ N(\sigma) = \frac{-g \: \sigma \: +!! \frac{\partial\Theta}{\partial\sigma}}{\Theta \:R \:T} \f$ +!! +!! The environmental variables are calculated from a mass weighted vertical +!! average over a base layer. G(Fr) is a monotonically increasing +!! function of Froude number, +!! +!! \f$ F_{r} = \frac{N h^{'}}{U} \f$ +!! +!! where U is the wind speed calculated as a mass weighted vertical average in +!! the base layer, and h', is the vertical displacement caused by the orography +!! variance. An effective mountain length for the gravity wave processes, +!! +!! \f$ l^{*} = \frac{\Delta X}{m} \f$ +!! +!! where m is the number of mountains in a grid box, can then +!! be defined to obtain the form of the base level stress +!! +!! +!! \f$ \tau = \frac {\rho \: U^{3} \: G(F_{r})} {N \;l^{*}} \f$ +!! +!! giving the stress induced from the surface in a model grid box. +!! PH gives the form for the function G(Fr) as +!! +!! +!! \f$ G(F_{r}) = \bar{G}\frac{F^{2}_{r}}{F^{2}_{r}\: + \:a^{2}} \f$ +!! +!! Where \f$ \bar{G} \f$ is an order unity non-dimensional saturation +!! flux set to 1 and 'a' is a function of the mountain aspect ratio also +!!set to 1 in the 1987 implementation of the GFS GWD. Typical values of +!! U=10m/s, N=0.01 1/s, l*=100km, and a=1, gives a flux of 1 Pascal and +!! if this flux is made to go to zero linearly with height then the +!! decelerations would be about 10/m/s/day which is consistent with +!! observations in PH. +!! +!! +!! In Kim, Moorthi, Alpert's (1998, 2001) GWD currently in GFS operations, +!! the GWD scheme has the same physical basis as in Alpert (1987) with the addition +!! of enhancement factors for the amplitude, G, and mountain shape details +!! in G(Fr) to account for effects from the mountain blocking. A factor, +!! E m’, is an enhancement factor on the stress in the Alpert '87 scheme. +!! The E ranges from no enhancement to an upper limit of 3, E=E(OA)[1-3], +!! and is a function of OA, the Orographic Asymmetry defined in KA (1995) as +!! +!! Orographic Asymmetry (OA) = \f$ \frac{ \bar{x} \; - \; +!! \sum\limits_{j=1}^{N_{b}} x_{j} \; n_{j} }{\sigma_{x}} \f$ +!! +!! where Nb is the total number of bottom blocks in the mountain barrier, +!! \f$ \sigma_{x} \f$ is the standard deviation of the horizontal distance defined by +!! +!! \f$ \sigma_{x} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{b}} +!! \; (x_{j} \; - \; \bar{x} )^2}{N_{x}} } \f$ +!! +!! +!! where Nx is the number of grid intervals for the large scale domain being +!! considered. So the term, E(OA)m’/ \f$ \Delta X \f$ in Kim's scheme represents +!! a multiplier on G shown in Alpert's eq (1), where m’ is the number of mountains +!! in a sub-grid scale box. Kim increased the complexity of m’ making it a +!! function of the fractional area of the sub-grid mountain and the asymmetry +!! and convexity statistics which are found from running a gravity wave +!! model for a large number of cases: +!! +!! \f$ m^{'} = C_{m} \Delta X \left[ \frac{1 \; + \; +!! \sum\limits_{x} L_{h} }{\Delta X} \right]^{OA+1} \f$ +!! +!! Where, according to Kim, \f$ \sum \frac{L_{h}}{\Delta X} \f$ is +!! the fractional area covered by the subgrid-scale orography higher than +!! a critical height \f$ h_{c} = Fr_{c} U_{0}/N_{0} \f$ , over the +!! "low level" vertically averaged layer, for a grid box with the interval +!! \f$ \Delta X \f$. Each \f$ L_{n}\f$ is the width of a segment of +!! orography intersection at the critical height: +!! +!! \f$ Fr_{0} = \frac{N_{0} \; h^{'}}{U_{0}} \f$ +!! +!! \f$ G^{'}(OC,Fr_{0}) = \frac{Fr_{0}^{2}}{Fr_{0}^{2} \; + \; a^{2}} \f$ +!! +!! \f$ a^{2} = \frac{C_{G}}{OC} \f$ +!! +!! \f$ E(OA, Fr_{0}) = (OA \; + \; 2)^{\delta} \f$ and \f$ \delta +!! \; = \; \frac{C_{E} \; Fr_{0}}{Fr_{c}} \f$ where \f$ Fr_{c} \f$ +!! is as in Alpert. +!! +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when the +!! minimum Richardson number: +!! +!! Orographic Convexity (OC) = \f$ \frac{ \sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h})^4 }{N_{x} \;\sigma_{h}^4} \f$ , +!! and where \f$ \sigma_{h} = \sqrt{ \frac{\sum\limits_{j=1}^{N_{x}} +!! \; (h_{j} \; - \; \bar{h} )^2}{N_{x}} } \f$ +!! +!! This represents a closed scheme, somewhat empirical adjustments +!! to the original scheme to calculate the surface stress. +!! +!! Momentum is deposited by the sub-grid scale gravity waves break due +!! to the presence of convective mixing assumed to occur when +!! the minimum Richardson number: +!! +!! \f$ Ri_{m} = \frac{Ri(1 \; - \; Fr)}{(1 \; + \; \sqrt{Ri}Fr)^2} \f$ +!! +!! Is less than 1/4 Or if critical layers are encountered in a layer +!! the the momentum flux will vanish. The critical layer is defined +!! when the base layer wind becomes perpendicular to the environmental +!! wind. Otherwise, wave breaking occurs at a level where the amplification +!! of the wave causes the local Froude number or similarly a truncated +!! (first term of the) Scorer parameter, to be reduced below a critical +!! value by the saturation hypothesis (Lindzen,). This is done through +!! eq 1 which can be written as +!! +!! \f$ \tau = \rho U N k h^{'2} \f$ +!! +!! For small Froude number this is discretized in the vertical so at each +!! level the stress is reduced by ratio of the Froude or truncated Scorer +!! parameter, \f$ \frac{U^{2}}{N^{2}} = \frac{N \tau_{l-1}}{\rho U^{3} k} \f$ , +!! where the stress is from the layer below beginning with that found near +!! the surface. The respective change in momentum is applied in +!! that layer building up from below. +!! +!! An amplitude factor is part of the calibration of this scheme which is +!! a function of the model resolution and the vertical diffusion. This +!! is because the vertical diffusion and the GWD account encompass +!! similar physical processes. Thus, one needs to run the model over +!! and over for various amplitude factors for GWD and vertical diffusion. +!! +!! In addition, there is also mountain blocking from lift and frictional +!! forces. Improved integration between how the GWD is calculated and +!! the mountain blocking of wind flow around sub-grid scale orography +!! is underway at NCEP. The GFS already has convectively forced GWD +!! an independent process. The next step is to test +!! +!> \section det_drag_suite GFS Orographic GWD Scheme Detailed Algorithm +!> @{ +! subroutine drag_suite_run( & +! & IM,IX,KM,A,B,C,U1,V1,T1,Q1,KPBL, & +! & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & +! & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & +! & DUSFC,DVSFC,G, CP, RD, RV, IMX, & +! & nmtvr, cdmbgwd, me, lprnt, ipr, rdxzb, errmsg, errflg) +! + subroutine drag_suite_run( & + & IM,IX,KM,dvdt,dudt,dtdt,U1,V1,T1,Q1,KPBL, & + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM,KDT, & + & VAR,oc1,oa4,ol4, & +! & varss,oc1ss,oa4ss,ol4ss, & + & THETA,SIGMA,GAMMA,ELVMAX, & + & dtaux2d_ls,dtauy2d_ls,dtaux2d_bl,dtauy2d_bl, & + & dtaux2d_ss,dtauy2d_ss,dtaux2d_fd,dtauy2d_fd, & + & dusfc,dvsfc, & + & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & + & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & + & slmsk,br1,hpbl, & + & g, cp, rd, rv, fv, pi, imx, cdmbgwd, & + & me, lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! ----- This code ----- +!begin WRF code + +! this code handles the time tendencies of u v due to the effect of mountain +! induced gravity wave drag from sub-grid scale orography. this routine +! not only treats the traditional upper-level wave breaking due to mountain +! variance (alpert 1988), but also the enhanced lower-tropospheric wave +! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). +! thus, in addition to the terrain height data in a model grid box, +! additional 10-2d topographic statistics files are needed, including +! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) +! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography +! hong (1999). the current scheme was implmented as in hong et al.(2008) +! +! Originally coded by song-you hong and young-joon kim and implemented by song-you hong +! +! program history log: +! 2014-10-01 Hyun-Joo Choi (from KIAPS) flow-blocking drag of kim and doyle +! with blocked height by dividing streamline theory +! 2017-04-06 Joseph Olson (from Gert-Jan Steeneveld) added small-scale +! orographic grabity wave drag: +! 2017-09-15 Joseph Olson, with some bug fixes from Michael Toy: added the +! topographic form drag of Beljaars et al. (2004, QJRMS) +! Activation of each component is done by specifying the integer-parameters +! (defined below) to 0: inactive or 1: active +! gwd_opt_ls = 0 or 1: large-scale +! gwd_opt_bl = 0 or 1: blocking drag +! gwd_opt_ss = 0 or 1: small-scale gravity wave drag +! gwd_opt_fd = 0 or 1: topographic form drag +! 2017-09-25 Michael Toy (from NCEP GFS model) added dissipation heating +! gsd_diss_ht_opt = 0: dissipation heating off +! gsd_diss_ht_opt = 1: dissipation heating on +! +! References: +! Hong et al. (2008), wea. and forecasting +! Kim and Doyle (2005), Q. J. R. Meteor. Soc. +! Kim and Arakawa (1995), j. atmos. sci. +! Alpert et al. (1988), NWP conference. +! Hong (1999), NCEP office note 424. +! Steeneveld et al (2008), JAMC +! Tsiringakis et al. (2017), Q. J. R. Meteor. Soc. +! Beljaars et al. (2004), Q. J. R. Meteor. Soc. +! +! notice : comparible or lower resolution orography files than model resolution +! are desirable in preprocess (wps) to prevent weakening of the drag +!------------------------------------------------------------------------------- +! +! input +! dudt (im,km) non-lin tendency for u wind component +! dvdt (im,km) non-lin tendency for v wind component +! u1(im,km) zonal wind / sqrt(rcl) m/sec at t0-dt +! v1(im,km) meridional wind / sqrt(rcl) m/sec at t0-dt +! t1(im,km) temperature deg k at t0-dt +! q1(im,km) specific humidity at t0-dt +! deltim time step secs +! del(km) positive increment of pressure across layer (pa) +! KPBL(IM) is the index of the top layer of the PBL +! ipr & lprnt for diagnostics +! +! output +! dudt, dvdt wind tendency due to gwdo +! dTdt +! +!------------------------------------------------------------------------------- + +!end wrf code +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM CCPP (AFTER CALLING PBL SCHEMES) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V +! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED +! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING +! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF +! CRITICAL LEVELS +! +! +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none + + ! Interface variables + integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, gwd_opt + logical, intent(in) :: lprnt + integer, intent(in) :: KPBL(im) + real(kind=kind_phys):: deltim, G, CP, RD, RV, cdmbgwd(2) + + integer :: kpblmax + integer, parameter :: ims=1, kms=1, its=1, kts=1 + real :: fv, pi, rcl, cdmb + real, parameter :: g_inv = 1./9.81 !1./g + + real(kind=kind_phys), intent(out) :: & + & dudt(im,km),dvdt(im,km), & + & dtdt(im,km), rdxzb(im) + real(kind=kind_phys), intent(in) :: & + & u1(im,km),v1(im,km), & + & t1(im,km),q1(im,km), & + & PHII(im,km+1),prsl(im,km), & + & prslk(im,km),PHIL(im,km) + real(kind=kind_phys), intent(in) :: prsi(im,km+1), & + & del(im,km) + real(kind=kind_phys), intent(in) :: var(im),oc1(im), & + & oa4(im,4),ol4(im,4), & + & dx(im) + !real(kind=kind_phys), intent(in) :: varss(im),oc1ss(im), & + real :: varss(im),oc1ss(im), & + & oa4ss(im,4),ol4ss(im,4) + real(kind=kind_phys), intent(in) :: THETA(im),SIGMA(im), & + & GAMMA(im),ELVMAX(im) + +! added for small-scale orographic wave drag + real, dimension(im,km) :: utendwave,vtendwave,thx,thvx + real(kind=kind_phys), intent(in) :: br1(im), & + & hpbl(im), & + & slmsk(im) + real, dimension(im) :: govrth,xland + real, dimension(im,km) :: dz2 + real :: tauwavex0,tauwavey0, & + & XNBV,density,tvcon,hpbl2 + integer :: kpbl2,kvar + real, dimension(im,km+1) :: zq ! = PHII/g + real, dimension(im,km) :: zl ! = PHIL/g + +!SPP + real, dimension(im) :: rstoch + +!Output: + real(kind=kind_phys), intent(out) :: & + & dusfc(im), dvsfc(im) +!Output (optional): + real(kind=kind_phys), intent(out) :: & + & dusfc_ls(:),dvsfc_ls(:), & + & dusfc_bl(:),dvsfc_bl(:), & + & dusfc_ss(:),dvsfc_ss(:), & + & dusfc_fd(:),dvsfc_fd(:) + real(kind=kind_phys), intent(out) :: & + & dtaux2d_ls(:,:),dtauy2d_ls(:,:), & + & dtaux2d_bl(:,:),dtauy2d_bl(:,:), & + & dtaux2d_ss(:,:),dtauy2d_ss(:,:), & + & dtaux2d_fd(:,:),dtauy2d_fd(:,:) + +!Misc arrays + real, dimension(im,km) :: dtaux2d, dtauy2d + +!------------------------------------------------------------------------- +! Flags to regulate the activation of specific components of drag suite: +! Each component is tapered off automatically as a function of dx, so best to +! keep them activated (=1). + integer, parameter :: & + gwd_opt_ls = 1, & ! large-scale gravity wave drag + gwd_opt_bl = 1, & ! blocking drag + gwd_opt_ss = 1, & ! small-scale gravity wave drag (Steeneveld et al. 2008) + gwd_opt_fd = 1, & ! form drag (Beljaars et al. 2004, QJRMS) + gsd_diss_ht_opt = 0 + +! Parameters for bounding the scale-adaptive variability: +! Small-scale GWD + turbulent form drag + real, parameter :: dxmin_ss = 1000., & + & dxmax_ss = 12000. ! min,max range of tapering (m) +! Large-scale GWD + blocking + real, parameter :: dxmin_ls = 3000., & + & dxmax_ls = 13000. ! min,max range of tapering (m) + real :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) +! +! Variables for limiting topographic standard deviation (var) + real, parameter :: varmax_ss = 50., & + varmax_fd = 150., & + beta_ss = 0.1, & + beta_fd = 0.2 + real :: var_temp + +! added Beljaars orographic form drag + real, dimension(im,km) :: utendform,vtendform + real :: a1,a2,wsp + real :: H_efold + +! critical richardson number for wave breaking : ! larger drag with larger value + real,parameter :: ric = 0.25 + real,parameter :: dw2min = 1. + real,parameter :: rimin = -100. + real,parameter :: bnv2min = 1.0e-5 + real,parameter :: efmin = 0.0 + real,parameter :: efmax = 10.0 + real,parameter :: xl = 4.0e4 + real,parameter :: critac = 1.0e-5 + real,parameter :: gmax = 1. + real,parameter :: veleps = 1.0 + real,parameter :: factop = 0.5 + real,parameter :: frc = 1.0 + real,parameter :: ce = 0.8 + real,parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 + +! +! local variables +! + integer :: i,j,k,lcap,lcapp1,nwd,idir, & + klcap,kp1,ikount,kk +! + real :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & + rcsks,wdir,ti,rdz,temp,tem2,dw2,shr2, & + bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & + rim,temc,tem1,efact,temv,dtaux,dtauy, & + dtauxb,dtauyb,eng0,eng1 +! + logical :: ldrag(im),icrilv(im), & + flag(im),kloop1(im) +! + real :: taub(im),taup(im,km+1), & + xn(im),yn(im), & + ubar(im),vbar(im), & + fr(im),ulow(im), & + rulow(im),bnv(im), & + oa(im),ol(im), & + oass(im),olss(im), & + roll(im),dtfac(im), & + brvf(im),xlinv(im), & + delks(im),delks1(im), & + bnv2(im,km),usqj(im,km), & + taud_ls(im,km),taud_bl(im,km), & + ro(im,km), & + vtk(im,km),vtj(im,km), & + zlowtop(im),velco(im,km-1), & + coefm(im),coefm_ss(im) +! + integer :: kbl(im),klowtop(im) + logical :: iope + integer,parameter :: mdir=8 + integer :: nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ +! +! variables for flow-blocking drag +! + real,parameter :: frmax = 10. + real,parameter :: olmin = 1.0e-5 + real,parameter :: odmin = 0.1 + real,parameter :: odmax = 10. + real,parameter :: erad = 6371.315e+3 + integer :: komax(im) + integer :: kblk + real :: cd + real :: zblk,tautem + real :: pe,ke + real :: delx,dely,dxy4(4),dxy4p(4) + real :: dxy(im),dxyp(im) + real :: ol4p(4),olp(im),od(im) + real :: taufb(im,km+1) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +print*,"Running drag suite" +!-------------------------------------------------------------------- +! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME +!-------------------------------------------------------------------- +! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) +! non-dim sub grid mtn drag Amp (*j*) +! cdmb = 1.0/float(IMX/192) +! cdmb = 192.0/float(IMX) + cdmb = 4.0 * 192.0/float(IMX) + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) + +!>-# Orographic Gravity Wave Drag Section + kpblmax = km / 2 ! maximum pbl height : # of vertical levels / 2 +! +! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 +! + if (imx > 0) then +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192)/float(IMX/192) +! cleff = 1.0E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + cleff = 0.5E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! hmhj for ndsl +! jw cleff = 0.1E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + endif + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +!-------------------------------------------------------------------- +! END SCALE-ADPTIVE PARAMETER SECTION +!-------------------------------------------------------------------- +! +!---- constants +! + rcl = 1. + rcs = sqrt(rcl) + cs = 1. / sqrt(rcl) + csg = cs * g + lcap = km + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi) + + do i=1,im + if (slmsk(i)==1. .or. slmsk(i)==2.) then !sea/land/ice mask (=0/1/2) in FV3 + xland(i)=1.0 !but land/water = (1/2) in this module + else + xland(i)=2.0 + endif + RDXZB(i) = 0.0 + enddo + +!temporary use of large-scale data: + do i=1,im + varss(i)=var(i) + oc1ss(i)=oc1(i) + do j=1,4 + oa4ss(i,j)=oa4(i,j) + ol4ss(i,j)=ol4(i,j) + enddo + enddo +! +!--- calculate scale-aware tapering factors +!NOTE: if dx(1) is not representative of most/all dx, this needs to change... +if ( dx(1) .ge. dxmax_ls ) then + ls_taper = 1. +else + if ( dx(1) .le. dxmin_ls) then + ls_taper = 0. + else + ls_taper = 0.5 * ( SIN(pi*(dx(1)-0.5*(dxmax_ls+dxmin_ls))/ & + (dxmax_ls-dxmin_ls)) + 1. ) + end if +end if +print*,"in Drag Suite, dx(1:2):",dx(1),dx(2) +if ( dx(1) .ge. dxmax_ss ) then + ss_taper = 1. +else + if ( dx(1) .le. dxmin_ss) then + ss_taper = 0. + else + ss_taper = dxmax_ss * (1. - dxmin_ss/dx(1))/(dxmax_ss-dxmin_ss) + end if +end if +print*,"in Drag Suite, ss_taper:",ss_taper + +!--- calculate length of grid for flow-blocking drag +! + delx = dx(1) + dely = dx(1) + dxy4(1) = delx + dxy4(2) = dely + dxy4(3) = sqrt(delx*delx + dely*dely) + dxy4(4) = dxy4(3) + dxy4p(1) = dxy4(2) + dxy4p(2) = dxy4(1) + dxy4p(3) = dxy4(4) + dxy4p(4) = dxy4(3) +! +!-----initialize arrays +! + dtaux = 0.0 + dtauy = 0.0 + do i = its,im + klowtop(i) = 0 + kbl(i) = 0 + enddo +! + do i = its,im + xn(i) = 0.0 + yn(i) = 0.0 + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + taub (i) = 0.0 + oa(i) = 0.0 + ol(i) = 0.0 + oass(i) = 0.0 + olss(i) = 0.0 + ulow (i) = 0.0 + dtfac(i) = 1.0 + ldrag(i) = .false. + icrilv(i) = .false. + flag(i) = .true. + enddo + + do k = kts,km + do i = its,im + usqj(i,k) = 0.0 + bnv2(i,k) = 0.0 + vtj(i,k) = 0.0 + vtk(i,k) = 0.0 + taup(i,k) = 0.0 + taud_ls(i,k) = 0.0 + taud_bl(i,k) = 0.0 + dtaux2d(i,k) = 0.0 + dtauy2d(i,k) = 0.0 + enddo + enddo +! + if (gwd_opt == 33) then + do i = its,im + dusfc_ls(i) = 0.0 + dvsfc_ls(i) = 0.0 + dusfc_bl(i) = 0.0 + dvsfc_bl(i) = 0.0 + dusfc_ss(i) = 0.0 + dvsfc_ss(i) = 0.0 + dusfc_fd(i) = 0.0 + dvsfc_fd(i) = 0.0 + enddo + do k = kts,km + do i = its,im + dtaux2d_ls(i,k)= 0.0 + dtauy2d_ls(i,k)= 0.0 + dtaux2d_bl(i,k)= 0.0 + dtauy2d_bl(i,k)= 0.0 + dtaux2d_ss(i,k)= 0.0 + dtauy2d_ss(i,k)= 0.0 + dtaux2d_fd(i,k)= 0.0 + dtauy2d_fd(i,k)= 0.0 + enddo + enddo + endif + + do i = its,im + taup(i,km+1) = 0.0 + xlinv(i) = 1.0/xl + dusfc(i) = 0.0 + dvsfc(i) = 0.0 + enddo +! +! initialize array for flow-blocking drag +! + taufb(1:im,1:km+1) = 0.0 + komax(1:im) = 0 +! + do k = kts,km + do i = its,im + vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 + enddo + enddo +! +! determine reference level: maximum of 2*var and pbl heights +! + do i = its,im + zlowtop(i) = 2. * var(i) + enddo +! + do i = its,im + kloop1(i) = .true. + enddo +! + do k = kts+1,km + do i = its,im + if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + enddo + enddo +! + do i = its,im + kbl(i) = max(kpbl(i), klowtop(i)) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + ! komax(:) = kbl(:) + komax(:) = klowtop(:) - 1 ! modification by NOAA/GSD March 2018 +! + do i = its,im + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,im + if (k.lt.kbl(i)) then + rcsks = rcs * del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean + endif + enddo + enddo +! +! figure out low-level horizontal wind direction +! +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! + do i = its,im + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) + ! Repeat for small-scale gwd + oass(i) = (1-2*int( (nwd-1)/4 )) * oa4ss(i,mod(nwd-1,4)+1) + olss(i) = ol4ss(i,mod(nwd-1,4)+1) + +! +!----- compute orographic width along (ol) and perpendicular (olp) +!----- the direction of wind +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +!----- compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +!----- compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(MOD(nwd-1,4)+1) + enddo +! +! END INITIALIZATION; BEGIN GWD CALCULATIONS: +! +IF ( ((gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1)).and. & + (ls_taper .GT. 1.E-02) ) THEN !==== +! +!--- saving richardson number in usqj for migwdi +! + do k = kts,km-1 + do i = its,im + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = rcl*(tem1*tem1 + tem2*tem2) + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + bnv2(i,k) = max( bnv2(i,k), bnv2min ) + enddo + enddo +! +!----compute the "low level" or 1/3 wind magnitude (m/s) +! + do i = its,im + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) + rulow(i) = 1./ulow(i) + enddo +! + do k = kts,km-1 + do i = its,im + velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then + velco(i,k) = veleps + endif + enddo + enddo +! +! no drag when critical level in the base layer +! + do i = its,im + ldrag(i) = velco(i,1).le.0. + enddo +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. + enddo + enddo +! +! no drag when bnv2.lt.0 +! + do k = kts,kpblmax + do i = its,im + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. + enddo + enddo +! +!-----the low level weighted average ri is stored in usqj(1,1; im) +!-----the low level weighted average n**2 is stored in bnv2(1,1; im) +!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 +!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + do i = its,im + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) + enddo +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo + enddo +! + do i = its,im + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + enddo +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + do i = its,im + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo + enddo +! + do i = its,im + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * 2. * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) + endif + enddo +! +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt + + do i = its,im + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) +!!!!!!! cleff (effective grid length) is highly tunable parameter +!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag +!WRF cleff = sqrt(dxy(i)**2. + dxyp(i)**2.) +!WRF cleff = 3. * max(dx(i),cleff) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) +!WRF xlinv(i) = coefm(i) / cleff + xlinv(i) = coefm(i) * cleff + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + if ( gwd_opt_ls .NE. 0 ) then + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else ! We've gotten what we need for the blocking scheme + taub(i) = 0.0 + end if + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + enddo + +ENDIF ! (gwd_opt_ls .EQ. 1).or.(gwd_opt_bl .EQ. 1) + +!========================================================= +! add small-scale wavedrag for stable boundary layer +!========================================================= + XNBV=0. + tauwavex0=0. + tauwavey0=0. + density=1.2 + utendwave=0. + vtendwave=0. + zq=0. +! + IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running small-scale gravity wave drag" +! +! declaring potential temperature +! + do k = kts,km + do i = its,im + thx(i,k) = t1(i,k)/prslk(i,k) + enddo + enddo +! + do k = kts,km + do i = its,im + tvcon = (1.+fv*q1(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo + ! Calculate mid-layer height (zl), interface height (zq), and layer depth (dz2). + do k = kts,km + do i = its,im + zq(i,k+1) = PHII(i,k+1)*g_inv + dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv + zl(i,k) = PHIL(i,k)*g_inv + enddo + enddo + + do i=its,im + hpbl2 = hpbl(i)+10. + kpbl2 = kpbl(i) + !kvar = MIN(kpbl, k-level of var) + kvar = 1 + do k=kts+1,MAX(kpbl(i),kts+1) +! IF (zl(i,k)>2.*var(i) .or. zl(i,k)>2*varmax) then + IF (zl(i,k)>300.) then + kpbl2 = k + IF (k == kpbl(i)) then + hpbl2 = hpbl(i)+10. + ELSE + hpbl2 = zl(i,k)+10. + ENDIF + exit + ENDIF + enddo + if((xland(i)-1.5).le.0. .and. 2.*varss(i).le.hpbl(i))then + if(br1(i).gt.0. .and. thvx(i,kpbl2)-thvx(i,kts) > 0.)then +!WRF cleff_ss = sqrt(dxy(i)**2 + dxyp(i)**2) +! cleff_ss = 3. * max(dx(i),cleff_ss) +! cleff_ss = 10. * max(dxmax_ss,cleff_ss) +!WRF cleff_ss = 0.1 * max(dxmax_ss,cleff_ss) + cleff_ss = 0.1 * 12000. + coefm_ss(i) = (1. + olss(i)) ** (oass(i)+1.) + xlinv(i) = coefm_ss(i) / cleff_ss + !govrth(i)=g/(0.5*(thvx(i,kpbl(i))+thvx(i,kts))) + govrth(i)=g/(0.5*(thvx(i,kpbl2)+thvx(i,kts))) + !XNBV=sqrt(govrth(i)*(thvx(i,kpbl(i))-thvx(i,kts))/hpbl(i)) + XNBV=sqrt(govrth(i)*(thvx(i,kpbl2)-thvx(i,kts))/hpbl2) +! + !if(abs(XNBV/u1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/u1(i,kpbl2)).gt.xlinv(i))then + !tauwavex0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*u1(i,kpbl(i)) + !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,kpbl2) + !tauwavex0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*u1(i,3) + var_temp = MIN(varss(i),varmax_ss) + & + MAX(0.,beta_ss*(varss(i)-varmax_ss)) + tauwavex0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*u1(i,kvar) + tauwavex0=tauwavex0*ss_taper + else + tauwavex0=0. + endif +! + !if(abs(XNBV/v1(i,kpbl(i))).gt.xlinv(i))then + if(abs(XNBV/v1(i,kpbl2)).gt.xlinv(i))then + !tauwavey0=0.5*XNBV*xlinv(i)*(2*MIN(varss(i),75.))**2*ro(i,kts)*v1(i,kpbl(i)) + !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,kpbl2) + !tauwavey0=0.5*XNBV*xlinv(i)*(2.*MIN(varss(i),40.))**2*ro(i,kts)*v1(i,3) + var_temp = MIN(varss(i),varmax_ss) + & + MAX(0.,beta_ss*(varss(i)-varmax_ss)) + tauwavey0=0.5*XNBV*xlinv(i)*(2.*var_temp)**2*ro(i,kvar)*v1(i,kvar) + tauwavey0=tauwavey0*ss_taper + else + tauwavey0=0. + endif + + do k=kts,kpbl(i) !MIN(kpbl2+1,km-1) +!original + !utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) + !vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl(i)),0.)/hpbl(i) +!new + utendwave(i,k)=-1.*tauwavex0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 + vtendwave(i,k)=-1.*tauwavey0*2.*max((1.-zl(i,k)/hpbl2),0.)/hpbl2 +!mod-to be used in HRRRv3/RAPv4 + !utendwave(i,k)=-1.*tauwavex0 * max((1.-zl(i,k)/hpbl2),0.)**2 + !vtendwave(i,k)=-1.*tauwavey0 * max((1.-zl(i,k)/hpbl2),0.)**2 + enddo + endif + endif + enddo ! end i loop + + do k = kts,km + do i = its,im + dudt(i,k) = dudt(i,k) + utendwave(i,k) + dvdt(i,k) = dvdt(i,k) + vtendwave(i,k) + dusfc(i) = dusfc(i) + utendwave(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendwave(i,k) * del(i,k) + enddo + enddo + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dusfc_ss(i) = dusfc_ss(i) + utendwave(i,k) * del(i,k) + dvsfc_ss(i) = dvsfc_ss(i) + vtendwave(i,k) * del(i,k) + dtaux2d_ss(i,k) = utendwave(i,k) + dtauy2d_ss(i,k) = vtendwave(i,k) + enddo + enddo + endif + +ENDIF ! end if gwd_opt_ss == 1 + +!================================================================ +! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): +!================================================================ +IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running form drag" + + utendform=0. + vtendform=0. + zq=0. + + IF ( (gwd_opt_ss .NE. 1).and.(ss_taper.GT.1.E-02) ) THEN + ! Defining mid-layer height (zl), interface height (zq), and layer depth (dz2). + ! This is already done above if the small-scale GWD is activated. + do k = kts,km + do i = its,im + zq(i,k+1) = PHII(i,k+1)*g_inv + dz2(i,k) = (PHII(i,k+1)-PHII(i,k))*g_inv + zl(i,k) = PHIL(i,k)*g_inv + enddo + enddo + ENDIF + + DO i=its,im + IF ((xland(i)-1.5) .le. 0.) then + !(IH*kflt**n1)**-1 = (0.00102*0.00035**-1.9)**-1 = 0.00026615161 + var_temp = MIN(varss(i),varmax_fd) + & + MAX(0.,beta_fd*(varss(i)-varmax_fd)) + var_temp = MIN(var_temp, 250.) + a1=0.00026615161*var_temp**2 +! a1=0.00026615161*MIN(varss(i),varmax)**2 +! a1=0.00026615161*(0.5*varss(i))**2 + ! k1**(n1-n2) = 0.003**(-1.9 - -2.8) = 0.003**0.9 = 0.005363 + a2=a1*0.005363 + ! Revise e-folding height based on PBL height and topographic std. dev. -- M. Toy 3/12/2018 + H_efold = max(2*varss(i),hpbl(i)) + H_efold = min(H_efold,1500.) + DO k=kts,km + wsp=SQRT(u1(i,k)**2 + v1(i,k)**2) + ! alpha*beta*Cmd*Ccorr*2.109 = 12.*1.*0.005*0.6*2.109 = 0.0759 + utendform(i,k)=-0.0759*wsp*u1(i,k)* & + EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper + vtendform(i,k)=-0.0759*wsp*v1(i,k)* & + EXP(-(zl(i,k)/H_efold)**1.5)*a2*zl(i,k)**(-1.2)*ss_taper + !IF(zl(i,k) > 4000.) exit + ENDDO + ENDIF + ENDDO + + do k = kts,km + do i = its,im + dudt(i,k) = dudt(i,k) + utendform(i,k) + dvdt(i,k) = dvdt(i,k) + vtendform(i,k) + dusfc(i) = dusfc(i) + utendform(i,k) * del(i,k) + dvsfc(i) = dvsfc(i) + vtendform(i,k) * del(i,k) + enddo + enddo + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dtaux2d_fd(i,k) = utendform(i,k) + dtauy2d_fd(i,k) = vtendform(i,k) + dusfc_fd(i) = dusfc_fd(i) + utendform(i,k) * del(i,k) + dvsfc_fd(i) = dvsfc_fd(i) + vtendform(i,k) * del(i,k) + enddo + enddo + endif + +ENDIF ! end if gwd_opt_fd == 1 +!======================================================= +! More for the large-scale gwd component +IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN + print*,"in Drag Suite: Running large-scale gravity wave drag" +! +! now compute vertical structure of the stress. + do k = kts,kpblmax + do i = its,im + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo +! + do k = kpblmin, km-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,im +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + .or. (velco(i,k) .le. 0.0) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo +! + do i = its,im + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then + temv = 1.0 / velco(i,k) + tem1 = coefm(i)/dxy(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv +! +! rim is the minimum-richardson number by shutts (1985) + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) +! +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions +! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo +! + if(lcap.lt.km) then + do klcap = lcapp1,km + do i = its,im + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + +ENDIF !END LARGE-SCALE TAU CALCULATION +!=============================================================== +!COMPUTE BLOCKING COMPONENT +!=============================================================== +IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN + print*,"in Drag Suite: Running blocking drag" + + do i = its,im + if(.not.ldrag(i)) then +! +!------- determine the height of flow-blocking layer +! + kblk = 0 + pe = 0.0 + do k = km, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) + ke = 0.5*((rcs*u1(i,k))**2.+(rcs*v1(i,k))**2.) +! +!---------- apply flow-blocking drag when pe >= ke +! + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + RDXZB(i) = real(k,kind=kind_phys) + endif + endif + enddo + if(kblk.ne.0) then +! +!--------- compute flow-blocking stress +! + cd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5 * roll(i) * coefm(i) / max(dxmax_ls,dxy(i))**2 * cd * dxyp(i) & + * olp(i) * zblk * ulow(i)**2 + tautem = taufb(i,kts)/float(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +!----------sum orographic GW stress and flow-blocking stress +! + ! taup(i,:) = taup(i,:) + taufb(i,:) ! Keep taup and taufb separate for now + endif + endif + enddo + +ENDIF ! end blocking drag +!=========================================================== +IF ( (gwd_opt_ls .EQ. 1 .OR. gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,km + do i = its,im + taud_ls(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + taud_bl(i,k) = 1. * (taufb(i,k+1) - taufb(i,k)) * csg / del(i,k) + enddo + enddo +! +! limit de-acceleration (momentum deposition ) at top to 1/2 value +! the idea is some stuff must go out the 'top' + do klcap = lcap,km + do i = its,im + taud_ls(i,klcap) = taud_ls(i,klcap) * factop + taud_bl(i,klcap) = taud_bl(i,klcap) * factop + enddo + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,im + if (k .le. kbl(i)) then + if((taud_ls(i,k)+taud_bl(i,k)).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & + /(deltim*rcs*(taud_ls(i,k)+taud_bl(i,k))))) + endif + enddo + enddo +! + do k = kts,km + do i = its,im + taud_ls(i,k) = taud_ls(i,k) * dtfac(i) * ls_taper *(1.-rstoch(i)) + taud_bl(i,k) = taud_bl(i,k) * dtfac(i) * ls_taper *(1.-rstoch(i)) + + dtaux = taud_ls(i,k) * xn(i) + dtauy = taud_ls(i,k) * yn(i) + dtauxb = taud_bl(i,k) * xn(i) + dtauyb = taud_bl(i,k) * yn(i) + + !add blocking and large-scale contributions to tendencies + dudt(i,k) = dtaux + dtauxb + dudt(i,k) + dvdt(i,k) = dtauy + dtauyb + dvdt(i,k) + + if ( gsd_diss_ht_opt .EQ. 1 ) then + ! Calculate dissipation heating + ! Initial kinetic energy (at t0-dt) + eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) + ! Kinetic energy after wave-breaking/flow-blocking + eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux2d_ls(i,k)+dtaux2d_bl(i,k))*deltim))**2 + & + (rcs*(v1(i,k)+(dtauy2d_ls(i,k)+dtauy2d_bl(i,k))*deltim))**2 ) + ! Modify theta tendency + dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim/prslk(i,k) + end if + + dusfc(i) = dusfc(i) + taud_ls(i,k)*xn(i)*del(i,k) + taud_bl(i,k)*xn(i)*del(i,k) + dvsfc(i) = dvsfc(i) + taud_ls(i,k)*yn(i)*del(i,k) + taud_bl(i,k)*yn(i)*del(i,k) + enddo + enddo + + ! Finalize dusfc and dvsfc diagnostics + do i = its,im + dusfc(i) = (-1./g*rcs) * dusfc(i) + dvsfc(i) = (-1./g*rcs) * dvsfc(i) + enddo + + if (gwd_opt == 33) then + do k = kts,km + do i = its,im + dtaux2d_ls(i,k) = taud_ls(i,k) * xn(i) + dtauy2d_ls(i,k) = taud_ls(i,k) * yn(i) + dtaux2d_bl(i,k) = taud_bl(i,k) * xn(i) + dtauy2d_bl(i,k) = taud_bl(i,k) * yn(i) + dusfc_ls(i) = dusfc_ls(i) + dtaux2d_ls(i,k) * del(i,k) + dvsfc_ls(i) = dvsfc_ls(i) + dtauy2d_ls(i,k) * del(i,k) + dusfc_bl(i) = dusfc_bl(i) + dtaux2d_bl(i,k) * del(i,k) + dvsfc_bl(i) = dvsfc_bl(i) + dtauy2d_bl(i,k) * del(i,k) + enddo + enddo + endif + +ENDIF + +if (gwd_opt == 33) then + ! Finalize dusfc and dvsfc diagnostics + do i = its,im + dusfc_ls(i) = (-1./g*rcs) * dusfc_ls(i) + dvsfc_ls(i) = (-1./g*rcs) * dvsfc_ls(i) + dusfc_bl(i) = (-1./g*rcs) * dusfc_bl(i) + dvsfc_bl(i) = (-1./g*rcs) * dvsfc_bl(i) + dusfc_ss(i) = (-1./g*rcs) * dusfc_ss(i) + dvsfc_ss(i) = (-1./g*rcs) * dvsfc_ss(i) + dusfc_fd(i) = (-1./g*rcs) * dusfc_fd(i) + dvsfc_fd(i) = (-1./g*rcs) * dvsfc_fd(i) + enddo +endif +! + return + end subroutine drag_suite_run +!------------------------------------------------------------------- +! +!> \section arg_table_drag_suite_finalize Argument Table +!! + subroutine drag_suite_finalize() + end subroutine drag_suite_finalize + + end module drag_suite + +!> This module contains the CCPP-compliant orographic gravity wave drag post +!! interstitial codes. + module drag_suite_post + + contains + +!! \section arg_table_drag_suite_post_init Argument Table +!! + subroutine drag_suite_post_init() + end subroutine drag_suite_post_init + +!! \section arg_table_drag_suite_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------------------------|---------------------------------------------------------------------------|-------|------|-----------|-----------|--------|----------| +!! | lssav | flag_diagnostics | flag for calculating diagnostic fields | flag | 0 | logical | | in | F | +!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | +!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | +!! | dusfcg | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | +!! | dvsfcg | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | +!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | +!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | +!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | in | F | +!! | dugwd | time_integral_of_x_stress_due_to_gravity_wave_drag | integral over time of zonal stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | +!! | dvgwd | time_integral_of_y_stress_due_to_gravity_wave_drag | integral over time of meridional stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | +!! | du3dt | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in zonal wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dv3dt | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in meridional wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | +!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine drag_suite_post_run( & + & lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & + & dugwd, dvgwd, du3dt, dv3dt, dt3dt, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + logical, intent(in) :: lssav, ldiag3d + real(kind=kind_phys), intent(in) :: dtf + real(kind=kind_phys), intent(in) :: & + & dusfcg(:), dvsfcg(:), dudt(:,:), dvdt(:,:), dtdt(:,:) + + real(kind=kind_phys), intent(inout) :: & + & dugwd(:), dvgwd(:), du3dt(:,:), dv3dt(:,:), dt3dt(:,:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (lssav) then + dugwd(:) = dugwd(:) + dusfcg(:)*dtf + dvgwd(:) = dvgwd(:) + dvsfcg(:)*dtf + + if (ldiag3d) then + du3dt(:,:) = du3dt(:,:) + dudt(:,:) * dtf + dv3dt(:,:) = dv3dt(:,:) + dvdt(:,:) * dtf + dt3dt(:,:) = dt3dt(:,:) + dtdt(:,:) * dtf + endif + endif + + end subroutine drag_suite_post_run + +!> \section arg_table_drag_suite_post_finalize Argument Table +!! + subroutine drag_suite_post_finalize() + end subroutine drag_suite_post_finalize + + end module drag_suite_post From 89fd3704b0efe45f64bb5487548ae8658c78f541 Mon Sep 17 00:00:00 2001 From: Michael Toy Date: Tue, 24 Sep 2019 21:15:30 +0000 Subject: [PATCH 34/36] Incorporated changes suggested in PR review --- CMakeLists.txt | 1 + physics/drag_suite.F90 | 38 +++++++++++++++++++++++--------------- 2 files changed, 24 insertions(+), 15 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index bfcceebc6..ad8a8c1f8 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -166,6 +166,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 + ./physics/drag_suite.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index a8ed0fc1b..627f636eb 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -196,6 +196,7 @@ end subroutine drag_suite_init !! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | !! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | !! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | +!! | master | mpi_root | master MPI-rank | index | 0 | integer | | in | F | !! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | !! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | !! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | @@ -384,8 +385,8 @@ subroutine drag_suite_run( & & dusfc_ls,dvsfc_ls,dusfc_bl,dvsfc_bl, & & dusfc_ss,dvsfc_ss,dusfc_fd,dvsfc_fd, & & slmsk,br1,hpbl, & - & g, cp, rd, rv, fv, pi, imx, cdmbgwd, & - & me, lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) + & g, cp, rd, rv, fv, pi, imx, cdmbgwd, me, master, & + & lprnt, ipr, rdxzb, dx, gwd_opt, errmsg, errflg ) ! ******************************************************************** ! -----> I M P L E M E N T A T I O N V E R S I O N <---------- @@ -474,15 +475,17 @@ subroutine drag_suite_run( & implicit none ! Interface variables - integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, gwd_opt + integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, master + inteter, intent(in) :: gwd_opt logical, intent(in) :: lprnt integer, intent(in) :: KPBL(im) - real(kind=kind_phys):: deltim, G, CP, RD, RV, cdmbgwd(2) + real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(2) integer :: kpblmax integer, parameter :: ims=1, kms=1, its=1, kts=1 - real :: fv, pi, rcl, cdmb - real, parameter :: g_inv = 1./9.81 !1./g + real, intent(in) :: fv, pi + real :: rcl, cdmb + real :: g_inv = 1./G real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -644,11 +647,16 @@ subroutine drag_suite_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + + ! Calculate inverse of gravitational acceleration + g_inv = 1./G + + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 -print*,"Running drag suite" +if (me==master) print *,"Running drag suite" !-------------------------------------------------------------------- ! SCALE-ADPTIVE PARAMETER FROM GFS GWD SCHEME !-------------------------------------------------------------------- @@ -722,7 +730,7 @@ subroutine drag_suite_run( & (dxmax_ls-dxmin_ls)) + 1. ) end if end if -print*,"in Drag Suite, dx(1:2):",dx(1),dx(2) +if (me==master) print *,"in Drag Suite, dx(1:2):",dx(1),dx(2) if ( dx(1) .ge. dxmax_ss ) then ss_taper = 1. else @@ -732,7 +740,7 @@ subroutine drag_suite_run( & ss_taper = dxmax_ss * (1. - dxmin_ss/dx(1))/(dxmax_ss-dxmin_ss) end if end if -print*,"in Drag Suite, ss_taper:",ss_taper +if (me==master) print *,"in Drag Suite, ss_taper:",ss_taper !--- calculate length of grid for flow-blocking drag ! @@ -1070,7 +1078,7 @@ subroutine drag_suite_run( & zq=0. ! IF ( (gwd_opt_ss .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running small-scale gravity wave drag" + if (me==master) print *,"in Drag Suite: Running small-scale gravity wave drag" ! ! declaring potential temperature ! @@ -1192,7 +1200,7 @@ subroutine drag_suite_run( & ! Topographic Form Drag from Beljaars et al. (2004, QJRMS, equ. 16): !================================================================ IF ( (gwd_opt_fd .EQ. 1).and.(ss_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running form drag" + if (me==master) print *,"in Drag Suite: Running form drag" utendform=0. vtendform=0. @@ -1259,7 +1267,7 @@ subroutine drag_suite_run( & !======================================================= ! More for the large-scale gwd component IF ( (gwd_opt_ls .EQ. 1).and.(ls_taper.GT.1.E-02) ) THEN - print*,"in Drag Suite: Running large-scale gravity wave drag" + if (me==master) print *,"in Drag Suite: Running large-scale gravity wave drag" ! ! now compute vertical structure of the stress. do k = kts,kpblmax @@ -1327,7 +1335,7 @@ subroutine drag_suite_run( & !COMPUTE BLOCKING COMPONENT !=============================================================== IF ( (gwd_opt_bl .EQ. 1) .and. (ls_taper .GT. 1.E-02) ) THEN - print*,"in Drag Suite: Running blocking drag" + if (me==master) print *,"in Drag Suite: Running blocking drag" do i = its,im if(.not.ldrag(i)) then @@ -1425,8 +1433,8 @@ subroutine drag_suite_run( & ! Initial kinetic energy (at t0-dt) eng0 = 0.5*( (rcs*u1(i,k))**2. + (rcs*v1(i,k))**2. ) ! Kinetic energy after wave-breaking/flow-blocking - eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux2d_ls(i,k)+dtaux2d_bl(i,k))*deltim))**2 + & - (rcs*(v1(i,k)+(dtauy2d_ls(i,k)+dtauy2d_bl(i,k))*deltim))**2 ) + eng1 = 0.5*( (rcs*(u1(i,k)+(dtaux+dtauxb)*deltim))**2 + & + (rcs*(v1(i,k)+(dtauy+dtauyb)*deltim))**2 ) ! Modify theta tendency dtdt(i,k) = dtdt(i,k) + max((eng0-eng1),0.0)/cp/deltim/prslk(i,k) end if From 5b7201d04806773fd90df2a27250f954f5e150af Mon Sep 17 00:00:00 2001 From: climbfuji Date: Fri, 27 Sep 2019 16:36:29 -0600 Subject: [PATCH 35/36] Revert change to CMakeLists.txt, convert physics/drag_suite.F90 to new metadata format --- CMakeLists.txt | 1 - physics/drag_suite.F90 | 217 +++------- physics/drag_suite.meta | 862 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 923 insertions(+), 157 deletions(-) create mode 100644 physics/drag_suite.meta diff --git a/CMakeLists.txt b/CMakeLists.txt index 2bf559811..443d7ea51 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -166,7 +166,6 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/module_MYNNSFC_wrapper.F90 ./physics/module_MYNNrad_pre.F90 ./physics/module_MYNNrad_post.F90 - ./physics/drag_suite.F90 ./physics/module_mp_thompson_make_number_concentrations.F90 ./physics/module_SF_JSFC.F90 ./physics/module_BL_MYJPBL.F90 diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 627f636eb..83a36f206 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -13,22 +13,8 @@ module drag_suite_pre subroutine drag_suite_pre_init() end subroutine drag_suite_pre_init -!! \section arg_table_drag_suite_pre_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------------------------|------------------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal dimension | count | 0 | integer | | in | F | -!! | nmtvr | number_of_statistical_measures_of_subgrid_orography | number of statistical measures of subgrid orography | count | 0 | integer | | in | F | -!! | mntvar | statistical_measures_of_subgrid_orography | array of statistical measures of subgrid orography | various | 2 | real | kind_phys | in | F | -!! | hprime | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | oc | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | out | F | -!! | clx | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | out | F | -!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with_respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | out | F | -!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | out | F | -!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | out | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_pre_run Argument Table +!! \htmlinclude drag_suite_pre_run.html !! !! \section general General Algorithm !! \section detailed Detailed Algorithm @@ -136,74 +122,8 @@ end subroutine drag_suite_init !! subgrid scale orography including convective breaking, shear !! breaking and the presence of critical levels. !! -!! \section arg_table_drag_suite_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-------------------------------------------------------------------------------|----------------------------------------------------------------------------------------------------------|------------|------|-----------|-----------|--------|----------| -!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | -!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | -!! | km | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | inout | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | inout | F | -!! | u1 | x_wind | zonal wind | m s-1 | 2 | real | kind_phys | in | F | -!! | v1 | y_wind | meridional wind | m s-1 | 2 | real | kind_phys | in | F | -!! | t1 | air_temperature | mid-layer temperature | K | 2 | real | kind_phys | in | F | -!! | q1 | water_vapor_specific_humidity | mid-layer specific humidity of water vapor | kg kg-1 | 2 | real | kind_phys | in | F | -!! | kpbl | vertical_index_at_top_of_atmosphere_boundary_layer | vertical index at top atmospheric boundary layer | index | 1 | integer | | in | F | -!! | prsi | air_pressure_at_interface | interface pressure | Pa | 2 | real | kind_phys | in | F | -!! | del | air_pressure_difference_between_midlayers | difference between mid-layer pressures | Pa | 2 | real | kind_phys | in | F | -!! | prsl | air_pressure | mid-layer pressure | Pa | 2 | real | kind_phys | in | F | -!! | prslk | dimensionless_exner_function_at_model_layers | mid-layer Exner function | none | 2 | real | kind_phys | in | F | -!! | phii | geopotential_at_interface | interface geopotential | m2 s-2 | 2 | real | kind_phys | in | F | -!! | phil | geopotential | mid-layer geopotential | m2 s-2 | 2 | real | kind_phys | in | F | -!! | deltim | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | -!! | kdt | index_of_time_step | current time step index | index | 0 | integer | | in | F | -!! | var | standard_deviation_of_subgrid_orography | standard deviation of subgrid orography | m | 1 | real | kind_phys | in | F | -!! | oc1 | convexity_of_subgrid_orography | convexity of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | oa4 | asymmetry_of_subgrid_orography | asymmetry of subgrid orography | none | 2 | real | kind_phys | in | F | -!! | ol4 | fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height | horizontal fraction of grid box covered by subgrid orography higher than critical height | frac | 2 | real | kind_phys | in | F | -!! | theta | angle_from_east_of_maximum_subgrid_orographic_variations | angle with respect to east of maximum subgrid orographic variations | degrees | 1 | real | kind_phys | in | F | -!! | sigma | slope_of_subgrid_orography | slope of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | gamma | anisotropy_of_subgrid_orography | anisotropy of subgrid orography | none | 1 | real | kind_phys | in | F | -!! | elvmax | maximum_subgrid_orography | maximum of subgrid orography | m | 1 | real | kind_phys | inout | F | -!! | dtaux2d_ls | x_momentum_tendency_from_large_scale_gwd | x momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_ls | y_momentum_tendency_from_large_scale_gwd | y momentum tendency from large scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_bl | x_momentum_tendency_from_blocking_drag | x momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_bl | y_momentum_tendency_from_blocking_drag | y momentum tendency from blocking drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_ss | x_momentum_tendency_from_small_scale_gwd | x momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_ss | y_momentum_tendency_from_small_scale_gwd | y momentum tendency from small scale gwd | m s-2 | 2 | real | kind_phys | out | F | -!! | dtaux2d_fd | x_momentum_tendency_from_form_drag | x momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dtauy2d_fd | y_momentum_tendency_from_form_drag | y momentum tendency from form drag | m s-2 | 2 | real | kind_phys | out | F | -!! | dusfc | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | -!! | dvsfc | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | out | F | -!! | dusfc_ls | integrated_x_momentum_flux_from_large_scale_gwd | integrated x momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_ls | integrated_y_momentum_flux_from_large_scale_gwd | integrated y momentum flux from large scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_bl | integrated_x_momentum_flux_from_blocking_drag | integrated x momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_bl | integrated_y_momentum_flux_from_blocking_drag | integrated y momentum flux from blocking drag | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_ss | integrated_x_momentum_flux_from_small_scale_gwd | integrated x momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_ss | integrated_y_momentum_flux_from_small_scale_gwd | integrated y momentum flux from small scale gwd | Pa s | 1 | real | kind_phys | out | F | -!! | dusfc_fd | integrated_x_momentum_flux_from_form_drag | integrated x momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | -!! | dvsfc_fd | integrated_y_momentum_flux_from_form_drag | integrated y momentum flux from form drag | Pa s | 1 | real | kind_phys | out | F | -!! | slmsk | sea_land_ice_mask_real | landmask: sea/land/ice=0/1/2 | flag | 1 | real | kind_phys | in | F | -!! | br1 | bulk_richardson_number_at_lowest_model_level | bulk Richardson number at the surface | none | 1 | real | kind_phys | in | F | -!! | hpbl | atmosphere_boundary_layer_thickness | PBL thickness | m | 1 | real | kind_phys | in | F | -!! | g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | -!! | cp | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rd | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | rv | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | -!! | fv | ratio_of_vapor_to_dry_air_gas_constants_minus_one | (rv/rd) - 1 (rv = ideal gas constant for water vapor) | none | 0 | real | kind_phys | in | F | -!! | pi | pi | ratio of a circle's circumference to its diameter | radians | 0 | real | kind_phys | in | F | -!! | imx | number_of_equatorial_longitude_points | number of longitude points along the equator | count | 0 | integer | | in | F | -!! | cdmbgwd | multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag | multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag | none | 1 | real | kind_phys | in | F | -!! | me | mpi_rank | rank of the current MPI task | index | 0 | integer | | in | F | -!! | master | mpi_root | master MPI-rank | index | 0 | integer | | in | F | -!! | lprnt | flag_print | flag for debugging printouts | flag | 0 | logical | | in | F | -!! | ipr | horizontal_index_of_printed_column | horizontal index of column used in debugging printouts | index | 0 | integer | | in | F | -!! | rdxzb | level_of_dividing_streamline | level of the dividing streamline | none | 1 | real | kind_phys | out | F | -!! | dx | cell_size | size of the grid cell | m | 1 | real | kind_phys | in | F | -!! | gwd_opt | gwd_opt | flag to choose gwd scheme | flag | 0 | integer | | in | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_run Argument Table +!! \htmlinclude drag_suite_run.html !! !> \section gen_drag_suite GFS Orographic GWD Scheme General Algorithm !! -# Calculate subgrid mountain blocking @@ -476,16 +396,16 @@ subroutine drag_suite_run( & ! Interface variables integer, intent(in) :: im, ix, km, imx, kdt, ipr, me, master - inteter, intent(in) :: gwd_opt + integer, intent(in) :: gwd_opt logical, intent(in) :: lprnt integer, intent(in) :: KPBL(im) real(kind=kind_phys), intent(in) :: deltim, G, CP, RD, RV, cdmbgwd(2) - integer :: kpblmax - integer, parameter :: ims=1, kms=1, its=1, kts=1 - real, intent(in) :: fv, pi - real :: rcl, cdmb - real :: g_inv = 1./G + integer :: kpblmax + integer, parameter :: ims=1, kms=1, its=1, kts=1 + real(kind=kind_phys), intent(in) :: fv, pi + real(kind=kind_phys) :: rcl, cdmb + real(kind=kind_phys) :: g_inv = 1./G real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -501,26 +421,26 @@ subroutine drag_suite_run( & & oa4(im,4),ol4(im,4), & & dx(im) !real(kind=kind_phys), intent(in) :: varss(im),oc1ss(im), & - real :: varss(im),oc1ss(im), & + real(kind=kind_phys) :: varss(im),oc1ss(im), & & oa4ss(im,4),ol4ss(im,4) real(kind=kind_phys), intent(in) :: THETA(im),SIGMA(im), & & GAMMA(im),ELVMAX(im) ! added for small-scale orographic wave drag - real, dimension(im,km) :: utendwave,vtendwave,thx,thvx + real(kind=kind_phys), dimension(im,km) :: utendwave,vtendwave,thx,thvx real(kind=kind_phys), intent(in) :: br1(im), & & hpbl(im), & & slmsk(im) - real, dimension(im) :: govrth,xland - real, dimension(im,km) :: dz2 - real :: tauwavex0,tauwavey0, & + real(kind=kind_phys), dimension(im) :: govrth,xland + real(kind=kind_phys), dimension(im,km) :: dz2 + real(kind=kind_phys) :: tauwavex0,tauwavey0, & & XNBV,density,tvcon,hpbl2 integer :: kpbl2,kvar - real, dimension(im,km+1) :: zq ! = PHII/g - real, dimension(im,km) :: zl ! = PHIL/g + real(kind=kind_phys), dimension(im,km+1) :: zq ! = PHII/g + real(kind=kind_phys), dimension(im,km) :: zl ! = PHIL/g !SPP - real, dimension(im) :: rstoch + real(kind=kind_phys), dimension(im) :: rstoch !Output: real(kind=kind_phys), intent(out) :: & @@ -538,7 +458,7 @@ subroutine drag_suite_run( & & dtaux2d_fd(:,:),dtauy2d_fd(:,:) !Misc arrays - real, dimension(im,km) :: dtaux2d, dtauy2d + real(kind=kind_phys), dimension(im,km) :: dtaux2d, dtauy2d !------------------------------------------------------------------------- ! Flags to regulate the activation of specific components of drag suite: @@ -553,40 +473,40 @@ subroutine drag_suite_run( & ! Parameters for bounding the scale-adaptive variability: ! Small-scale GWD + turbulent form drag - real, parameter :: dxmin_ss = 1000., & + real(kind=kind_phys), parameter :: dxmin_ss = 1000., & & dxmax_ss = 12000. ! min,max range of tapering (m) ! Large-scale GWD + blocking - real, parameter :: dxmin_ls = 3000., & + real(kind=kind_phys), parameter :: dxmin_ls = 3000., & & dxmax_ls = 13000. ! min,max range of tapering (m) - real :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) + real(kind=kind_phys) :: ss_taper, ls_taper ! small- and large-scale tapering factors (-) ! ! Variables for limiting topographic standard deviation (var) - real, parameter :: varmax_ss = 50., & + real(kind=kind_phys), parameter :: varmax_ss = 50., & varmax_fd = 150., & beta_ss = 0.1, & beta_fd = 0.2 - real :: var_temp + real(kind=kind_phys) :: var_temp ! added Beljaars orographic form drag - real, dimension(im,km) :: utendform,vtendform - real :: a1,a2,wsp - real :: H_efold + real(kind=kind_phys), dimension(im,km) :: utendform,vtendform + real(kind=kind_phys) :: a1,a2,wsp + real(kind=kind_phys) :: H_efold ! critical richardson number for wave breaking : ! larger drag with larger value - real,parameter :: ric = 0.25 - real,parameter :: dw2min = 1. - real,parameter :: rimin = -100. - real,parameter :: bnv2min = 1.0e-5 - real,parameter :: efmin = 0.0 - real,parameter :: efmax = 10.0 - real,parameter :: xl = 4.0e4 - real,parameter :: critac = 1.0e-5 - real,parameter :: gmax = 1. - real,parameter :: veleps = 1.0 - real,parameter :: factop = 0.5 - real,parameter :: frc = 1.0 - real,parameter :: ce = 0.8 - real,parameter :: cg = 0.5 + real(kind=kind_phys), parameter :: ric = 0.25 + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: factop = 0.5 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 integer,parameter :: kpblmin = 2 ! @@ -595,7 +515,7 @@ subroutine drag_suite_run( & integer :: i,j,k,lcap,lcapp1,nwd,idir, & klcap,kp1,ikount,kk ! - real :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & + real(kind=kind_phys) :: rcs,rclcs,csg,fdir,cleff,cleff_ss,cs, & rcsks,wdir,ti,rdz,temp,tem2,dw2,shr2, & bvf2,rdelks,wtkbj,tem,gfobnv,hd,fro, & rim,temc,tem1,efact,temv,dtaux,dtauy, & @@ -604,7 +524,7 @@ subroutine drag_suite_run( & logical :: ldrag(im),icrilv(im), & flag(im),kloop1(im) ! - real :: taub(im),taup(im,km+1), & + real(kind=kind_phys) :: taub(im),taup(im,km+1), & xn(im),yn(im), & ubar(im),vbar(im), & fr(im),ulow(im), & @@ -624,25 +544,26 @@ subroutine drag_suite_run( & integer :: kbl(im),klowtop(im) logical :: iope integer,parameter :: mdir=8 - integer :: nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ + !integer :: nwdir(mdir) + !data nwdir/6,7,5,8,2,3,1,4/ + integer, parameter :: nwdir = (/6,7,5,8,2,3,1,4/) ! ! variables for flow-blocking drag ! - real,parameter :: frmax = 10. - real,parameter :: olmin = 1.0e-5 - real,parameter :: odmin = 0.1 - real,parameter :: odmax = 10. - real,parameter :: erad = 6371.315e+3 + real(kind=kind_phys),parameter :: frmax = 10. + real(kind=kind_phys),parameter :: olmin = 1.0e-5 + real(kind=kind_phys),parameter :: odmin = 0.1 + real(kind=kind_phys),parameter :: odmax = 10. + real(kind=kind_phys),parameter :: erad = 6371.315e+3 integer :: komax(im) integer :: kblk - real :: cd - real :: zblk,tautem - real :: pe,ke - real :: delx,dely,dxy4(4),dxy4p(4) - real :: dxy(im),dxyp(im) - real :: ol4p(4),olp(im),od(im) - real :: taufb(im,km+1) + real(kind=kind_phys) :: cd + real(kind=kind_phys) :: zblk,tautem + real(kind=kind_phys) :: pe,ke + real(kind=kind_phys) :: delx,dely,dxy4(4),dxy4p(4) + real(kind=kind_phys) :: dxy(im),dxyp(im) + real(kind=kind_phys) :: ol4p(4),olp(im),od(im) + real(kind=kind_phys) :: taufb(im,km+1) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -1498,29 +1419,13 @@ module drag_suite_post contains -!! \section arg_table_drag_suite_post_init Argument Table +!> \section arg_table_drag_suite_post_init Argument Table !! subroutine drag_suite_post_init() end subroutine drag_suite_post_init -!! \section arg_table_drag_suite_post_run Argument Table -!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | -!! |----------------|-----------------------------------------------------------------------------------------------|---------------------------------------------------------------------------|-------|------|-----------|-----------|--------|----------| -!! | lssav | flag_diagnostics | flag for calculating diagnostic fields | flag | 0 | logical | | in | F | -!! | ldiag3d | flag_diagnostics_3D | flag for calculating 3-D diagnostic fields | flag | 0 | logical | | in | F | -!! | dtf | time_step_for_dynamics | dynamics time step | s | 0 | real | kind_phys | in | F | -!! | dusfcg | instantaneous_x_stress_due_to_gravity_wave_drag | zonal surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | -!! | dvsfcg | instantaneous_y_stress_due_to_gravity_wave_drag | meridional surface stress due to orographic gravity wave drag | Pa | 1 | real | kind_phys | in | F | -!! | dudt | tendency_of_x_wind_due_to_model_physics | zonal wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | -!! | dvdt | tendency_of_y_wind_due_to_model_physics | meridional wind tendency due to model physics | m s-2 | 2 | real | kind_phys | in | F | -!! | dtdt | tendency_of_air_temperature_due_to_model_physics | air temperature tendency due to model physics | K s-1 | 2 | real | kind_phys | in | F | -!! | dugwd | time_integral_of_x_stress_due_to_gravity_wave_drag | integral over time of zonal stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | -!! | dvgwd | time_integral_of_y_stress_due_to_gravity_wave_drag | integral over time of meridional stress due to gravity wave drag | Pa s | 1 | real | kind_phys | inout | F | -!! | du3dt | cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag | cumulative change in zonal wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | -!! | dv3dt | cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag | cumulative change in meridional wind due to orographic gravity wave drag | m s-1 | 2 | real | kind_phys | inout | F | -!! | dt3dt | cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag | cumulative change in temperature due to orographic gravity wave drag | K | 2 | real | kind_phys | inout | F | -!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | -!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!> \section arg_table_drag_suite_post_run Argument Table +!! \htmlinclude drag_suite_post_run.html !! subroutine drag_suite_post_run( & & lssav, ldiag3d, dtf, dusfcg, dvsfcg, dudt, dvdt, dtdt, & diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta new file mode 100644 index 000000000..ab84e937f --- /dev/null +++ b/physics/drag_suite.meta @@ -0,0 +1,862 @@ +[ccpp-arg-table] + name = drag_suite_pre_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_pre_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[nmtvr] + standard_name = number_of_statistical_measures_of_subgrid_orography + long_name = number of statistical measures of subgrid orography + units = count + dimensions = () + type = integer + intent = in + optional = F +[mntvar] + standard_name = statistical_measures_of_subgrid_orography + long_name = array of statistical measures of subgrid orography + units = various + dimensions = (horizontal_dimension,number_of_statistical_measures_of_subgrid_orography) + type = real + kind = kind_phys + intent = in + optional = F +[hprime] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[oc] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = out + optional = F +[clx] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = out + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with_respect to east of maximum subgrid orographic variations + units = degrees + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = drag_suite_pre_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in + optional = F +[ix] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[km] + standard_name = vertical_dimension + long_name = number of vertical layers + units = count + dimensions = () + type = integer + intent = in + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[u1] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[t1] + standard_name = air_temperature + long_name = mid-layer temperature + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[q1] + standard_name = water_vapor_specific_humidity + long_name = mid-layer specific humidity of water vapor + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_dimension) + 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_dimension) + type = integer + intent = in + optional = F +[prsi] + standard_name = air_pressure_at_interface + long_name = interface pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = difference between mid-layer pressures + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prsl] + standard_name = air_pressure + long_name = mid-layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[prslk] + standard_name = dimensionless_exner_function_at_model_layers + long_name = mid-layer Exner function + units = none + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[phii] + standard_name = geopotential_at_interface + long_name = interface geopotential + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension_plus_one) + type = real + kind = kind_phys + intent = in + optional = F +[phil] + standard_name = geopotential + long_name = mid-layer geopotential + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[deltim] + standard_name = time_step_for_physics + long_name = physics time step + units = s + dimensions = () + type = real + kind = kind_phys + 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 +[var] + standard_name = standard_deviation_of_subgrid_orography + long_name = standard deviation of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oc1] + standard_name = convexity_of_subgrid_orography + long_name = convexity of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[oa4] + standard_name = asymmetry_of_subgrid_orography + long_name = asymmetry of subgrid orography + units = none + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[ol4] + standard_name = fraction_of_grid_box_with_subgrid_orography_higher_than_critical_height + long_name = horizontal fraction of grid box covered by subgrid orography higher than critical height + units = frac + dimensions = (horizontal_dimension,4) + type = real + kind = kind_phys + intent = in + optional = F +[theta] + standard_name = angle_from_east_of_maximum_subgrid_orographic_variations + long_name = angle with respect to east of maximum subgrid orographic variations + units = degrees + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[sigma] + standard_name = slope_of_subgrid_orography + long_name = slope of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gamma] + standard_name = anisotropy_of_subgrid_orography + long_name = anisotropy of subgrid orography + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[elvmax] + standard_name = maximum_subgrid_orography + long_name = maximum of subgrid orography + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dtaux2d_ls] + standard_name = x_momentum_tendency_from_large_scale_gwd + long_name = x momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ls] + standard_name = y_momentum_tendency_from_large_scale_gwd + long_name = y momentum tendency from large scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_bl] + standard_name = x_momentum_tendency_from_blocking_drag + long_name = x momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_bl] + standard_name = y_momentum_tendency_from_blocking_drag + long_name = y momentum tendency from blocking drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_ss] + standard_name = x_momentum_tendency_from_small_scale_gwd + long_name = x momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_ss] + standard_name = y_momentum_tendency_from_small_scale_gwd + long_name = y momentum tendency from small scale gwd + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtaux2d_fd] + standard_name = x_momentum_tendency_from_form_drag + long_name = x momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dtauy2d_fd] + standard_name = y_momentum_tendency_from_form_drag + long_name = y momentum tendency from form drag + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ls] + standard_name = integrated_x_momentum_flux_from_large_scale_gwd + long_name = integrated x momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ls] + standard_name = integrated_y_momentum_flux_from_large_scale_gwd + long_name = integrated y momentum flux from large scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_bl] + standard_name = integrated_x_momentum_flux_from_blocking_drag + long_name = integrated x momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_bl] + standard_name = integrated_y_momentum_flux_from_blocking_drag + long_name = integrated y momentum flux from blocking drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_ss] + standard_name = integrated_x_momentum_flux_from_small_scale_gwd + long_name = integrated x momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_ss] + standard_name = integrated_y_momentum_flux_from_small_scale_gwd + long_name = integrated y momentum flux from small scale gwd + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dusfc_fd] + standard_name = integrated_x_momentum_flux_from_form_drag + long_name = integrated x momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dvsfc_fd] + standard_name = integrated_y_momentum_flux_from_form_drag + long_name = integrated y momentum flux from form drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[slmsk] + standard_name = sea_land_ice_mask_real + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[br1] + standard_name = bulk_richardson_number_at_lowest_model_level + long_name = bulk Richardson number at the surface + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL thickness + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[g] + 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 +[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 +[rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[fv] + 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 +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = radians + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[imx] + standard_name = number_of_equatorial_longitude_points + long_name = number of longitude points along the equator + units = count + dimensions = () + type = integer + intent = in + optional = F +[cdmbgwd] + standard_name = multiplication_factors_for_mountain_blocking_and_orographic_gravity_wave_drag + long_name = multiplic. factors for (1) mountain blocking drag coeff. and (2) ref. level orographic gravity wave drag + units = none + dimensions = (2) + type = real + kind = kind_phys + intent = in + optional = F +[me] + standard_name = mpi_rank + long_name = rank of the current MPI task + units = index + dimensions = () + type = integer + intent = in + optional = F +[master] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in + optional = F +[lprnt] + standard_name = flag_print + long_name = flag for debugging printouts + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ipr] + standard_name = horizontal_index_of_printed_column + long_name = horizontal index of column used in debugging printouts + units = index + dimensions = () + type = integer + intent = in + optional = F +[rdxzb] + standard_name = level_of_dividing_streamline + long_name = level of the dividing streamline + units = none + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = out + optional = F +[dx] + standard_name = cell_size + long_name = size of the grid cell + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[gwd_opt] + standard_name = gwd_opt + long_name = flag to choose gwd scheme + units = flag + dimensions = () + type = integer + intent = in + optional = F +[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 = drag_suite_finalize + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_init + type = scheme + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_run + type = scheme +[lssav] + standard_name = flag_diagnostics + long_name = flag for calculating diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for calculating 3-D diagnostic fields + units = flag + dimensions = () + type = logical + intent = in + optional = F +[dtf] + standard_name = time_step_for_dynamics + long_name = dynamics time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[dusfcg] + standard_name = instantaneous_x_stress_due_to_gravity_wave_drag + long_name = zonal surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvsfcg] + standard_name = instantaneous_y_stress_due_to_gravity_wave_drag + long_name = meridional surface stress due to orographic gravity wave drag + units = Pa + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dudt] + standard_name = tendency_of_x_wind_due_to_model_physics + long_name = zonal wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dvdt] + standard_name = tendency_of_y_wind_due_to_model_physics + long_name = meridional wind tendency due to model physics + units = m s-2 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dtdt] + standard_name = tendency_of_air_temperature_due_to_model_physics + long_name = air temperature tendency due to model physics + units = K s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[dugwd] + standard_name = time_integral_of_x_stress_due_to_gravity_wave_drag + long_name = integral over time of zonal stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dvgwd] + standard_name = time_integral_of_y_stress_due_to_gravity_wave_drag + long_name = integral over time of meridional stress due to gravity wave drag + units = Pa s + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[du3dt] + standard_name = cumulative_change_in_x_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in zonal wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dv3dt] + standard_name = cumulative_change_in_y_wind_due_to_orographic_gravity_wave_drag + long_name = cumulative change in meridional wind due to orographic gravity wave drag + units = m s-1 + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[dt3dt] + standard_name = cumulative_change_in_temperature_due_to_orographic_gravity_wave_drag + long_name = cumulative change in temperature due to orographic gravity wave drag + units = K + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + +######################################################################## +[ccpp-arg-table] + name = drag_suite_post_finalize + type = scheme From 78c59108c4a900fae5daf7a956104973c70003f9 Mon Sep 17 00:00:00 2001 From: climbfuji Date: Sat, 28 Sep 2019 21:10:31 -0600 Subject: [PATCH 36/36] physics/drag_suite.F90: bugfixes --- physics/drag_suite.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/physics/drag_suite.F90 b/physics/drag_suite.F90 index 83a36f206..56902c631 100644 --- a/physics/drag_suite.F90 +++ b/physics/drag_suite.F90 @@ -405,7 +405,7 @@ subroutine drag_suite_run( & integer, parameter :: ims=1, kms=1, its=1, kts=1 real(kind=kind_phys), intent(in) :: fv, pi real(kind=kind_phys) :: rcl, cdmb - real(kind=kind_phys) :: g_inv = 1./G + real(kind=kind_phys) :: g_inv real(kind=kind_phys), intent(out) :: & & dudt(im,km),dvdt(im,km), & @@ -546,7 +546,7 @@ subroutine drag_suite_run( & integer,parameter :: mdir=8 !integer :: nwdir(mdir) !data nwdir/6,7,5,8,2,3,1,4/ - integer, parameter :: nwdir = (/6,7,5,8,2,3,1,4/) + integer, parameter :: nwdir(8) = (/6,7,5,8,2,3,1,4/) ! ! variables for flow-blocking drag ! @@ -568,11 +568,9 @@ subroutine drag_suite_run( & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - ! Calculate inverse of gravitational acceleration g_inv = 1./G - ! Initialize CCPP error handling variables errmsg = '' errflg = 0