From cf18dbb9bef51171f2bb75387b181a8ff55f9fb3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 30 Jul 2019 21:20:12 -0700 Subject: [PATCH 001/114] lpw diagnostic --- biogeophys/FatesPlantHydraulicsMod.F90 | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index d16a6d75b8..11c1ae72dd 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2483,6 +2483,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) write(fates_log(),*) 'ERROR in plant hydraulics.' write(fates_log(),*) 'The HLM predicted a non-zero total transpiration flux' write(fates_log(),*) 'for this patch, yet there is no leaf-area-weighted conductance?' + write(fates_log(),*) 'transp: ',bc_in(s)%qflx_transp_pa(ifp) + write(fates_log(),*) 'gscan_patch: ',gscan_patch call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -3327,6 +3329,9 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax real(r8) :: we_k ! error for kth node (temporary) [kg] real(r8) :: the_k ! theta error for kth node (temporary) [m3 m-3] real(r8) :: supsub_adj_w ! water ajustment due to super saturation or sub residual flag + real(r8) :: leaf_water ! total water in the leaf (kg/plant) + real(r8) :: stem_water ! "" kg/plant + real(r8) :: root_water ! total water in absorbing and transporting roots (kg/plant) logical :: catch_nan ! flag for nan returned from Tridiagaonal integer :: index_nan ! highest k index possessing a nan integer :: index_stem @@ -3546,6 +3551,23 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax thresh else if (abs(we_local) > thresh_break) then write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', thresh_break + write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' + + leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & + ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + + root_water = (sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',ccohort%dbh + write(fates_log(),*) 'pft: ',ccohort%pft + write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 0de5bb36ef75c5a6eef0ff0710eee1c8cdd96204 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Aug 2019 14:50:49 -0700 Subject: [PATCH 002/114] Minor syntax updates while investigating fates-hydro solver --- biogeophys/FatesPlantHydraulicsMod.F90 | 85 ++++++++++++++------------ 1 file changed, 47 insertions(+), 38 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 11c1ae72dd..5bf0b041be 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -893,11 +893,11 @@ subroutine UpdateWaterDepTreeHydrCond(currentSite,ccohort,nlevsoi_hyd,bc_in) do j=1, nlevsoi_hyd hksat_s = bc_in%hksat_sisl(j) * 1.e-3_r8 * 1/grav * 1.e6_r8 - if(ccohort_hydr%psi_aroot(j) cc_p ccohort_hydr => ccohort%co_hydr dth_node_outer(:) = 0._r8 we_local = 0._r8 @@ -3353,24 +3356,28 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax !! in case timestep needs to be chopped in half to balance water th_node_init(:) = th_node(:) - ! WATER BALANCE + ! Total water mass in the plant at the beginning of this solve [kg h2o] w_tot_beg_outer = sum(th_node(:)*v_node(:))*denh2o ! OUTER DO-WHILE LOOP !! cuts timestep in half until all sub-timesteps (inner do-while loop) balance the water budget iterh1 = 0 do while( iterh1 == 0 .or. ((abs(we_local) > thresh .or. supsub_flag /= 0) .and. iterh1 < maxiter) ) - dt_fac = max(imult*iterh1,1) - dt_fac2 = real(dt_fac,r8) - dt_new = dtime/dt_fac2 + + dt_fac = max(imult*iterh1,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. + + dt_new = dtime/real(dt_fac,r8) ! This is the sub-stem length in seconds + + ! Restore initial states for a fresh attempt using new sub-timesteps - !! restore initial states for a fresh attempt using new sub-timesteps if(iterh1 .gt. 0) then th_node(:) = th_node_init(:) end if ! QUANTITIES OF INTEREST - qtop_dt = 0._r8 + qtop_dt = 0._r8 ! Water loss through transpiration, integrated up to the substep [kg] dqtopdth_dthdt = 0._r8 sapflow = 0._r8 rootuptake = 0._r8 @@ -3398,7 +3405,7 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then if(flc_node(k) > flc_min_node(k)) then dflcdpsi_node(k) = 0._r8 - flc_node(k) = flc_min_node(k) + flc_node(k) = flc_min_node(k) end if end if enddo @@ -3426,10 +3433,10 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax ! SET BOUNDARY PRESSURE DIFFERENCES & CONDUCTANCES !! compute water potential differences + conductances and their derivatives wrt water potential call boundary_hdiff_and_k((n_hypool_tot-nshell), z_node, psi_node, flc_node, dflcdpsi_node, & - kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, dhdiffdpsi0, & - dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) - + kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, dhdiffdpsi0, & + dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & + kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + ! SET BOUNDARY FLUX TERMS !! compute flux terms and their derivatives wrt water content q_bound(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) @@ -3457,13 +3464,15 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax amx(k) = 0._r8 bmx(k) = dqbounddth0(k) - dqtopdth_leaf - v_node(k)*denh2o/dt_new cmx(k) = dqbounddth1(k) + !! intermediate nodes (plant and soil) do k=2,(n_hypool_tot-1) - rmx(k) = q_bound(k-1) - q_bound(k) - amx(k) = -1._r8 * dqbounddth0(k-1) - bmx(k) = dqbounddth0(k) - dqbounddth1(k-1) - v_node(k)*denh2o/dt_new - cmx(k) = dqbounddth1(k) + rmx(k) = q_bound(k-1) - q_bound(k) + amx(k) = -1._r8 * dqbounddth0(k-1) + bmx(k) = dqbounddth0(k) - dqbounddth1(k-1) - v_node(k)*denh2o/dt_new + cmx(k) = dqbounddth1(k) enddo + !! outermost rhizosphere shell k = n_hypool_tot rmx(k) = q_bound(k-1) @@ -3638,7 +3647,7 @@ end subroutine Hydraulics_Tridiagonal subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdpsi_node, & kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, & dhdiffdpsi0, dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) ! ! !ARGUMENTS integer , intent(in) :: k_arootsoil ! index of node where the boundary occurs between root and soil @@ -3687,13 +3696,13 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps ! examine direction of water flow; use the upstream node's k for the boundary k. ! (as suggested by Ethan Coon, LANL) if(hdiff_bound(k) < 0._r8) then - k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere - dkbounddpsi0(k) = 0._r8 - dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) + k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere + dkbounddpsi0(k) = 0._r8 + dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) else - k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil - dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) - dkbounddpsi1(k) = 0._r8 + k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil + dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) + dkbounddpsi1(k) = 0._r8 end if end if else From 6aa1344844045f360392de8e523c7a4a26935735 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 8 Aug 2019 13:19:20 -0700 Subject: [PATCH 003/114] Very under-construction changes going on with hydraulics. --- biogeophys/FatesPlantHydraulicsMod.F90 | 8023 ++++++++++++------------ main/FatesConstantsMod.F90 | 6 + 2 files changed, 3993 insertions(+), 4036 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5bf0b041be..453f1e7a1d 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1,200 +1,200 @@ module FatesPlantHydraulicsMod - ! ============================================================================================== - ! This module contains the relevant code for plant hydraulics. Currently, one hydraulics module - ! is available. Other methods of estimating plant hydraulics may become available in future - ! releases. For now, please cite the following reference if this module is used to generate - ! published research: - ! - ! Christoffersen, B.O., Gloor, M., Fauset, S., Fyllas, N. M., Galbraith, D. R., Baker, - ! T. R., Kruijt, B., Rowland, L., Fisher, R. A., Binks, O. J., Sevanto, S., Xu, C., Jansen, - ! S., Choat, B., Mencuccini, M., McDowell, N. G., Meir, P. Linking hydraulic traits to - ! tropical forest function in a size-structured and trait-driven model (TFS~v.1-Hydro). - ! Geoscientific Model Development, 9(11), 2016, pp: 4227-4255, - ! https://www.geosci-model-dev.net/9/4227/2016/, DOI = 10.5194/gmd-9-4227-2016. - ! - ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING - ! - ! PLANT HYDRAULICS IS AN EXPERIMENTAL OPTION THAT IS STILL UNDERGOING TESTING. - ! - ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING - ! - ! ============================================================================================== - - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 - ! (TODO: THE ROW WIDTH ON THIS MODULE ARE TOO LARGE. NAG COMPILERS - ! WILL FREAK IF LINES ARE TOO LONG. BEFORE SUBMITTING THIS TO - ! MASTER WE NEED TO GO THROUGH AND GET THESE LINES BELOW - ! 100 spaces (for readability), or 130 (for NAG) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 - - use FatesGlobals, only : endrun => fates_endrun - use FatesGlobals, only : fates_log - - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : fates_huge - use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water - use FatesConstantsMod, only : grav => grav_earth - use FatesConstantsMod, only : ifalse, itrue - use FatesConstantsMod, only : pi_const - use FatesConstantsMod, only : cm2_per_m2 - use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : nearzero - - use EDParamsMod , only : hydr_kmax_rsurf1 - use EDParamsMod , only : hydr_kmax_rsurf2 - - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type - - use FatesInterfaceMod , only : hlm_use_planthydro - - use FatesAllometryMod, only : bsap_allom - use FatesAllometryMod, only : CrownDepth - - use FatesHydraulicsMemMod, only: ed_site_hydr_type - use FatesHydraulicsMemMod, only: ed_cohort_hydr_type - use FatesHydraulicsMemMod, only: n_hypool_leaf - use FatesHydraulicsMemMod, only: n_hypool_tot - use FatesHydraulicsMemMod, only: n_hypool_stem - use FatesHydraulicsMemMod, only: numLWPmem - use FatesHydraulicsMemMod, only: n_hypool_troot - use FatesHydraulicsMemMod, only: n_hypool_aroot - use FatesHydraulicsMemMod, only: n_porous_media - use FatesHydraulicsMemMod, only: nshell - use FatesHydraulicsMemMod, only: n_hypool_ag - use FatesHydraulicsMemMod, only: porous_media - use FatesHydraulicsMemMod, only: cap_slp - use FatesHydraulicsMemMod, only: cap_int - use FatesHydraulicsMemMod, only: cap_corr - use FatesHydraulicsMemMod, only: rwcft - use FatesHydraulicsMemMod, only: C2B - use FatesHydraulicsMemMod, only: InitHydraulicsDerived - use FatesHydraulicsMemMod, only: nlevsoi_hyd_max - use FatesHydraulicsMemMod, only: cohort_recruit_water_layer - use FatesHydraulicsMemMod, only: recruit_water_avail_layer - - use PRTGenericMod, only : all_carbon_elements - use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ - use PRTGenericMod, only : store_organ, repro_organ, struct_organ - - use clm_time_manager , only : get_step_size, get_nstep - - use EDPftvarcon, only : EDPftvarcon_inst - - ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_infnan_mod , only : isnan => shr_infnan_isnan - - - implicit none - - private - integer, parameter :: van_genuchten = 1 - integer, parameter :: campbell = 2 - integer :: iswc = campbell - - ! 1=leaf, 2=stem, 3=troot, 4=aroot - ! Several of these may be better transferred to the parameter file in due time (RGK) - - integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran - ! 1 => use BC hydraulics; - ! 2 => use CX hydraulics - logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf - ! term be applied to the plant - ! hydraulics numerical solution? - logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling - ! (i.e., non-instantaneous) be considered - ! within plant hydraulics? - logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the - ! boundary between nodes be taken to be a - ! function of the upstream loss of - ! conductivity (flc)? - logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent - ! hydraulic properties and states be - ! updated every day when trees grow or - ! when recruitment happens? - logical,parameter :: debug = .false. !flag to report warning in hydro - - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - - ! We use this parameter as the value for which we set un-initialized values - real(r8), parameter :: un_initialized = -9.9e32_r8 - - - ! - ! !PUBLIC MEMBER FUNCTIONS: - public :: AccumulateMortalityWaterStorage - public :: RecruitWaterStorage - public :: hydraulics_drive - public :: InitHydrSites - public :: HydrSiteColdStart - public :: BTranForHLMDiagnosticsFromCohortHydr - public :: InitHydrCohort - public :: DeallocateHydrCohort - public :: UpdateH2OVeg - public :: CopyCohortHydraulics - public :: FuseCohortHydraulics - public :: updateSizeDepTreeHydProps - public :: updateWaterDepTreeHydProps - public :: updateSizeDepTreeHydStates - public :: initTreeHydStates - public :: updateSizeDepRhizHydProps - public :: updateSizeDepRhizHydStates - public :: RestartHydrStates - public :: SavePreviousCompartmentVolumes - public :: SavePreviousRhizVolumes - public :: UpdateTreeHydrNodes - public :: UpdateTreeHydrLenVolCond - public :: UpdateWaterDepTreeHydrCond - public :: ConstrainRecruitNumber - - !------------------------------------------------------------------------------ - ! 01/18/16: Created by Brad Christoffersen - ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen - !------------------------------------------------------------------------------ - + ! ============================================================================================== + ! This module contains the relevant code for plant hydraulics. Currently, one hydraulics module + ! is available. Other methods of estimating plant hydraulics may become available in future + ! releases. For now, please cite the following reference if this module is used to generate + ! published research: + ! + ! Christoffersen, B.O., Gloor, M., Fauset, S., Fyllas, N. M., Galbraith, D. R., Baker, + ! T. R., Kruijt, B., Rowland, L., Fisher, R. A., Binks, O. J., Sevanto, S., Xu, C., Jansen, + ! S., Choat, B., Mencuccini, M., McDowell, N. G., Meir, P. Linking hydraulic traits to + ! tropical forest function in a size-structured and trait-driven model (TFS~v.1-Hydro). + ! Geoscientific Model Development, 9(11), 2016, pp: 4227-4255, + ! https://www.geosci-model-dev.net/9/4227/2016/, DOI = 10.5194/gmd-9-4227-2016. + ! + ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING + ! + ! PLANT HYDRAULICS IS AN EXPERIMENTAL OPTION THAT IS STILL UNDERGOING TESTING. + ! + ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING + ! + ! ============================================================================================== + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + ! (TODO: THE ROW WIDTH ON THIS MODULE ARE TOO LARGE. NAG COMPILERS + ! WILL FREAK IF LINES ARE TOO LONG. BEFORE SUBMITTING THIS TO + ! MASTER WE NEED TO GO THROUGH AND GET THESE LINES BELOW + ! 100 spaces (for readability), or 130 (for NAG) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_huge + use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water + use FatesConstantsMod, only : grav_earth + use FatesConstantsMod, only : ifalse, itrue + use FatesConstantsMod, only : pi_const + use FatesConstantsMod, only : cm2_per_m2 + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : nearzero + + use EDParamsMod , only : hydr_kmax_rsurf1 + use EDParamsMod , only : hydr_kmax_rsurf2 + + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + + use FatesInterfaceMod , only : hlm_use_planthydro + + use FatesAllometryMod, only : bsap_allom + use FatesAllometryMod, only : CrownDepth + + use FatesHydraulicsMemMod, only: ed_site_hydr_type + use FatesHydraulicsMemMod, only: ed_cohort_hydr_type + use FatesHydraulicsMemMod, only: n_hypool_leaf + use FatesHydraulicsMemMod, only: n_hypool_tot + use FatesHydraulicsMemMod, only: n_hypool_stem + use FatesHydraulicsMemMod, only: numLWPmem + use FatesHydraulicsMemMod, only: n_hypool_troot + use FatesHydraulicsMemMod, only: n_hypool_aroot + use FatesHydraulicsMemMod, only: n_porous_media + use FatesHydraulicsMemMod, only: nshell + use FatesHydraulicsMemMod, only: n_hypool_ag + use FatesHydraulicsMemMod, only: porous_media + use FatesHydraulicsMemMod, only: cap_slp + use FatesHydraulicsMemMod, only: cap_int + use FatesHydraulicsMemMod, only: cap_corr + use FatesHydraulicsMemMod, only: rwcft + use FatesHydraulicsMemMod, only: C2B + use FatesHydraulicsMemMod, only: InitHydraulicsDerived + use FatesHydraulicsMemMod, only: nlevsoi_hyd_max + use FatesHydraulicsMemMod, only: cohort_recruit_water_layer + use FatesHydraulicsMemMod, only: recruit_water_avail_layer + + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ + use PRTGenericMod, only : store_organ, repro_organ, struct_organ + + use clm_time_manager , only : get_step_size, get_nstep + + use EDPftvarcon, only : EDPftvarcon_inst + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan + + + implicit none + + private + integer, parameter :: van_genuchten = 1 + integer, parameter :: campbell = 2 + integer :: iswc = campbell + + ! 1=leaf, 2=stem, 3=troot, 4=aroot + ! Several of these may be better transferred to the parameter file in due time (RGK) + + integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran + ! 1 => use BC hydraulics; + ! 2 => use CX hydraulics + logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf + ! term be applied to the plant + ! hydraulics numerical solution? + logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling + ! (i.e., non-instantaneous) be considered + ! within plant hydraulics? + logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the + ! boundary between nodes be taken to be a + ! function of the upstream loss of + ! conductivity (flc)? + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent + ! hydraulic properties and states be + ! updated every day when trees grow or + ! when recruitment happens? + logical,parameter :: debug = .false. !flag to report warning in hydro + + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + ! We use this parameter as the value for which we set un-initialized values + real(r8), parameter :: un_initialized = -9.9e32_r8 + + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: AccumulateMortalityWaterStorage + public :: RecruitWaterStorage + public :: hydraulics_drive + public :: InitHydrSites + public :: HydrSiteColdStart + public :: BTranForHLMDiagnosticsFromCohortHydr + public :: InitHydrCohort + public :: DeallocateHydrCohort + public :: UpdateH2OVeg + public :: CopyCohortHydraulics + public :: FuseCohortHydraulics + public :: updateSizeDepTreeHydProps + public :: updateWaterDepTreeHydProps + public :: updateSizeDepTreeHydStates + public :: initTreeHydStates + public :: updateSizeDepRhizHydProps + public :: updateSizeDepRhizHydStates + public :: RestartHydrStates + public :: SavePreviousCompartmentVolumes + public :: SavePreviousRhizVolumes + public :: UpdateTreeHydrNodes + public :: UpdateTreeHydrLenVolCond + public :: KmaxInnerShell + public :: ConstrainRecruitNumber + + !------------------------------------------------------------------------------ + ! 01/18/16: Created by Brad Christoffersen + ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen + !------------------------------------------------------------------------------ + contains - !------------------------------------------------------------------------------ - subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) - - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - real(r8),intent(in) :: dtime - - - select case (use_ed_planthydraulics) - - case (1) - - call FillDrainRhizShells(nsites, sites, bc_in, bc_out ) - call hydraulics_BC(nsites, sites,bc_in,bc_out,dtime ) - - case (2) - - !call Hydraulics_CX() - - case DEFAULT - - end select - - end subroutine Hydraulics_Drive - - ! ===================================================================================== - - subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) + !------------------------------------------------------------------------------ + subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + + + select case (use_ed_planthydraulics) + + case (1) + + call FillDrainRhizShells(nsites, sites, bc_in, bc_out ) + call hydraulics_BC(nsites, sites,bc_in,bc_out,dtime ) + + case (2) + + !call Hydraulics_CX() + + case DEFAULT + + end select + + end subroutine Hydraulics_Drive + + ! ===================================================================================== + + subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! It is assumed that the following state variables have been read in by ! the restart machinery. @@ -216,7 +216,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) type(bc_out_type) , intent(inout) :: bc_out(nsites) - + ! locals ! ---------------------------------------------------------------------------------- ! LL pointers @@ -229,19 +229,19 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + ccohort => cpatch%shortest do while(associated(ccohort)) - + ccohort_hydr => ccohort%co_hydr ! This calculates node heights call UpdateTreeHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & - sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) - + sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) + ! This calculates volumes, lengths and max conductances call UpdateTreeHydrLenVolCond(ccohort,sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) - + ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. call SavePreviousCompartmentVolumes(ccohort_hydr) @@ -262,10 +262,10 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ccohort => ccohort%taller enddo - + cpatch => cpatch%younger end do - + sites(s)%si_hydr%l_aroot_layer_init(:) = un_initialized sites(s)%si_hydr%r_node_shell_init(:,:) = un_initialized sites(s)%si_hydr%v_shell_init(:,:) = un_initialized @@ -281,16 +281,16 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) call SavePreviousRhizVolumes(sites(s), bc_in(s)) end do - + call UpdateH2OVeg(nsites,sites,bc_out) return - end subroutine RestartHydrStates - - ! ==================================================================================== + end subroutine RestartHydrStates + + ! ==================================================================================== + + subroutine initTreeHydStates(site_p, cc_p, bc_in) - subroutine initTreeHydStates(site_p, cc_p, bc_in) - ! REQUIRED INPUTS: ! ! csite%si_hydr%psisoi_liq_innershell(:) @@ -334,7 +334,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) call th_from_psi(ft, 4, ccohort_hydr%psi_aroot(j), ccohort_hydr%th_aroot(j), csite%si_hydr, bc_in ) end do - + !initialize plant water potentials at hydrostatic equilibrium (dh/dz = 0) !the assumption is made here that initial conditions for soil water will !be in (or at least close to) hydrostatic equilibrium as well, so that @@ -342,7 +342,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !potential is referenced to. do k=1, n_hypool_troot dz = ccohort_hydr%z_node_troot(k) - ccohort_hydr%z_node_aroot(1) - ccohort_hydr%psi_troot(k) = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav*dz + ccohort_hydr%psi_troot(k) = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot(k)>0.0_r8) ccohort_hydr%psi_troot(k) = -0.01_r8 call th_from_psi(ft, 3, ccohort_hydr%psi_troot(k), ccohort_hydr%th_troot(k), csite%si_hydr, bc_in) end do @@ -350,16 +350,16 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot(1) - ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot(1) - 1.e-6_r8*denh2o*grav*dz + ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 call th_from_psi(ft, 2, ccohort_hydr%psi_ag(n_hypool_ag), ccohort_hydr%th_ag(n_hypool_ag), csite%si_hydr, bc_in) do k=n_hypool_ag-1, 1, -1 dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) - ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - 1.e-6_r8*denh2o*grav*dz + ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - 1.e-6_r8*denh2o*grav_earth*dz if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), ccohort_hydr%th_ag(k), csite%si_hydr, bc_in) end do - + ccohort_hydr%lwp_mem(:) = ccohort_hydr%psi_ag(1) ! initializes the leaf water potential memory ccohort_hydr%lwp_stable = ccohort_hydr%psi_ag(1) ccohort_hydr%lwp_is_unstable = .false. ! inital value for leaf water potential stability flag @@ -379,138 +379,138 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%errh2o_pheno_aroot(:) = 0.0_r8 !ccohort_hydr%th_aroot_prev(:) = 0.0_r8 !ccohort_hydr%th_aroot_prev_ucnorr(:)= 0.0_r8 - + !initialize cohort-level btran call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - + end subroutine initTreeHydStates - + ! ===================================================================================== - + subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) - - ! -------------------------------------------------------------------------------- - ! This subroutine calculates the nodal heights critical to hydraulics in the plant - ! - ! Inputs: Plant height - ! Plant functional type - ! Number of soil hydraulic layers - ! - ! Outputs: cohort_hydr%z_node_ag(:) - ! %z_lower_ag(:) - ! %z_upper_ag(:) - ! %z_node_troot(:) - ! %z_lower_troot(:) - ! %z_upper_troot(:) - ! %z_node_aroot(:) - ! -------------------------------------------------------------------------------- - - ! Arguments - type(ed_cohort_hydr_type), intent(inout) :: ccohort_hydr - integer,intent(in) :: ft ! plant functional type index - real(r8), intent(in) :: plant_height ! [m] - integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions - - - ! Locals - - real(r8) :: roota ! root profile parameter a zeng2001_crootfr - real(r8) :: rootb ! root profile parameter b zeng2001_crootfr - real(r8) :: crown_depth ! crown depth for the plant [m] - real(r8) :: dz_canopy ! discrete crown depth intervals [m] - real(r8) :: z_stem ! the height of the plants stem below crown [m] - real(r8) :: dz_stem ! vertical stem discretization [m] - real(r8) :: dcumul_rf ! cumulative root distribution discretization [-] - real(r8) :: cumul_rf ! cumulative root distribution where depth is determined [-] - real(r8) :: z_cumul_rf ! depth at which cumul_rf occurs [m] - integer :: k ! Loop counter for compartments - - ! Crown Nodes - ! in special case where n_hypool_leaf = 1, the node height of the canopy - ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree - - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) - - call CrownDepth(plant_height,crown_depth) - - dz_canopy = crown_depth / real(n_hypool_leaf,r8) - do k=1,n_hypool_leaf - ccohort_hydr%z_lower_ag(k) = plant_height - dz_canopy*real(k,r8) - ccohort_hydr%z_node_ag(k) = ccohort_hydr%z_lower_ag(k) + 0.5_r8*dz_canopy - ccohort_hydr%z_upper_ag(k) = ccohort_hydr%z_lower_ag(k) + dz_canopy - enddo - - - ! Stem Nodes - ! in special case where n_hypool_stem = 1, the node height of the stem water pool is - ! 1/2 the height from the ground to the bottom of the canopy - z_stem = plant_height - crown_depth - dz_stem = z_stem / real(n_hypool_stem,r8) - do k=n_hypool_leaf+1,n_hypool_ag - ccohort_hydr%z_upper_ag(k) = real(n_hypool_stem - (k - 1 - n_hypool_leaf),r8)*dz_stem - ccohort_hydr%z_node_ag(k) = ccohort_hydr%z_upper_ag(k) - 0.5_r8*dz_stem - ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem - enddo - - ! Transporting Root Nodes - ! in special case where n_hypool_troot = 1, the node depth of the single troot pool - ! is the depth at which 50% total root distribution is attained - dcumul_rf = 1._r8/real(n_hypool_troot,r8) - - do k=1,n_hypool_troot - cumul_rf = dcumul_rf*real(k,r8) - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_lower_troot(k) = -z_cumul_rf - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf-0.5_r8*dcumul_rf, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_node_troot(k) = -z_cumul_rf - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf-1.0_r8*dcumul_rf+1.E-10_r8, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_upper_troot(k) = -z_cumul_rf - enddo - - - ! Absorbing root depth - ccohort_hydr%z_node_aroot(1:nlevsoi_hyd) = -bc_in%z_sisl(1:nlevsoi_hyd) - - - ! Shouldn't this be updating the upper and lower values as well? - ! (RGK 12-2018) - if(nlevsoi_hyd == 1) then - ccohort_hydr%z_node_troot(:) = ccohort_hydr%z_node_aroot(nlevsoi_hyd) - end if - - return + + ! -------------------------------------------------------------------------------- + ! This subroutine calculates the nodal heights critical to hydraulics in the plant + ! + ! Inputs: Plant height + ! Plant functional type + ! Number of soil hydraulic layers + ! + ! Outputs: cohort_hydr%z_node_ag(:) + ! %z_lower_ag(:) + ! %z_upper_ag(:) + ! %z_node_troot(:) + ! %z_lower_troot(:) + ! %z_upper_troot(:) + ! %z_node_aroot(:) + ! -------------------------------------------------------------------------------- + + ! Arguments + type(ed_cohort_hydr_type), intent(inout) :: ccohort_hydr + integer,intent(in) :: ft ! plant functional type index + real(r8), intent(in) :: plant_height ! [m] + integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers + type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions + + + ! Locals + + real(r8) :: roota ! root profile parameter a zeng2001_crootfr + real(r8) :: rootb ! root profile parameter b zeng2001_crootfr + real(r8) :: crown_depth ! crown depth for the plant [m] + real(r8) :: dz_canopy ! discrete crown depth intervals [m] + real(r8) :: z_stem ! the height of the plants stem below crown [m] + real(r8) :: dz_stem ! vertical stem discretization [m] + real(r8) :: dcumul_rf ! cumulative root distribution discretization [-] + real(r8) :: cumul_rf ! cumulative root distribution where depth is determined [-] + real(r8) :: z_cumul_rf ! depth at which cumul_rf occurs [m] + integer :: k ! Loop counter for compartments + + ! Crown Nodes + ! in special case where n_hypool_leaf = 1, the node height of the canopy + ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree + + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) + + call CrownDepth(plant_height,crown_depth) + + dz_canopy = crown_depth / real(n_hypool_leaf,r8) + do k=1,n_hypool_leaf + ccohort_hydr%z_lower_ag(k) = plant_height - dz_canopy*real(k,r8) + ccohort_hydr%z_node_ag(k) = ccohort_hydr%z_lower_ag(k) + 0.5_r8*dz_canopy + ccohort_hydr%z_upper_ag(k) = ccohort_hydr%z_lower_ag(k) + dz_canopy + enddo + + + ! Stem Nodes + ! in special case where n_hypool_stem = 1, the node height of the stem water pool is + ! 1/2 the height from the ground to the bottom of the canopy + z_stem = plant_height - crown_depth + dz_stem = z_stem / real(n_hypool_stem,r8) + do k=n_hypool_leaf+1,n_hypool_ag + ccohort_hydr%z_upper_ag(k) = real(n_hypool_stem - (k - 1 - n_hypool_leaf),r8)*dz_stem + ccohort_hydr%z_node_ag(k) = ccohort_hydr%z_upper_ag(k) - 0.5_r8*dz_stem + ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem + enddo + + ! Transporting Root Nodes + ! in special case where n_hypool_troot = 1, the node depth of the single troot pool + ! is the depth at which 50% total root distribution is attained + dcumul_rf = 1._r8/real(n_hypool_troot,r8) + + do k=1,n_hypool_troot + cumul_rf = dcumul_rf*real(k,r8) + call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + 0.001_r8, 0.001_r8, cumul_rf, z_cumul_rf) + z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) + ccohort_hydr%z_lower_troot(k) = -z_cumul_rf + call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + 0.001_r8, 0.001_r8, cumul_rf-0.5_r8*dcumul_rf, z_cumul_rf) + z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) + ccohort_hydr%z_node_troot(k) = -z_cumul_rf + call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + 0.001_r8, 0.001_r8, cumul_rf-1.0_r8*dcumul_rf+1.E-10_r8, z_cumul_rf) + z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) + ccohort_hydr%z_upper_troot(k) = -z_cumul_rf + enddo + + + ! Absorbing root depth + ccohort_hydr%z_node_aroot(1:nlevsoi_hyd) = -bc_in%z_sisl(1:nlevsoi_hyd) + + + ! Shouldn't this be updating the upper and lower values as well? + ! (RGK 12-2018) + if(nlevsoi_hyd == 1) then + ccohort_hydr%z_node_troot(:) = ccohort_hydr%z_node_aroot(nlevsoi_hyd) + end if + + return end subroutine UpdateTreeHydrNodes ! ===================================================================================== - + subroutine SavePreviousCompartmentVolumes(ccohort_hydr) type(ed_cohort_hydr_type),intent(inout) :: ccohort_hydr - - + + ! Saving the current compartment volumes into an "initial" save-space ! allows us to see how the compartments change size when plants ! change size and effect water contents - + ccohort_hydr%v_ag_init(:) = ccohort_hydr%v_ag(:) ccohort_hydr%v_troot_init(:) = ccohort_hydr%v_troot(:) ccohort_hydr%v_aroot_layer_init(:) = ccohort_hydr%v_aroot_layer(:) - + return end subroutine SavePreviousCompartmentVolumes - + ! ===================================================================================== - + subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) @@ -537,23 +537,23 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) ! Save the current vegetation compartment volumes into ! a save space so that it can be compared with the updated quantity. - + call SavePreviousCompartmentVolumes(ccohort_hydr) - + ! This updates all of the z_node positions call UpdateTreeHydrNodes(ccohort_hydr,ft,ccohort%hite,nlevsoi_hyd,bc_in) - + ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdateTreeHydrNodes is called prior to this. - + call UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) - + end subroutine updateSizeDepTreeHydProps - + ! ===================================================================================== - + subroutine updateWaterDepTreeHydProps(currentSite,ccohort,bc_in) @@ -577,355 +577,409 @@ subroutine updateWaterDepTreeHydProps(currentSite,ccohort,bc_in) nlevsoi_hyd = currentSite%si_hydr%nlevsoi_hyd ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - + ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdateTreeHydrNodes is called prior to this. - + call UpdateWaterDepTreeHydrCond(currentSite,ccohort,nlevsoi_hyd,bc_in) - - + + end subroutine updateWaterDepTreeHydProps ! ===================================================================================== subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) - - ! ----------------------------------------------------------------------------------- - ! This subroutine calculates three attributes of a plant: - ! 1) the volumes of storage compartments in the plants - ! 2) the lenghts of the organs - ! 3) the conductances - ! These and are not dependent on the hydraulic state of the - ! plant, it is more about the structural characteristics and how much biomass - ! is present in the different tissues. - ! - ! Inputs, plant geometries, plant carbon pools, z_node values - ! - ! ----------------------------------------------------------------------------------- - - ! Arguments - type(ed_cohort_type),intent(inout) :: ccohort - integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions - - type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure - integer :: j,k - integer :: ft ! Plant functional type index - real(r8) :: roota ! root profile parameter a zeng2001_crootfr - real(r8) :: rootb ! root profile parameter b zeng2001_crootfr - real(r8) :: leaf_c ! Current amount of leaf carbon in the plant [kg] - real(r8) :: fnrt_c ! Current amount of fine-root carbon in the plant [kg] - real(r8) :: sapw_c ! Current amount of sapwood carbon in the plant [kg] - real(r8) :: struct_c ! Current amount of structural carbon in the plant [kg] - real(r8) :: b_canopy_carb ! total leaf (canopy) biomass in carbon units [kgC/indiv] - real(r8) :: b_canopy_biom ! total leaf (canopy) biomass in dry wt units [kg/indiv] - real(r8) :: b_woody_carb ! total woody biomass in carbon units [kgC/indiv] - real(r8) :: b_woody_bg_carb ! belowground woody biomass in carbon units [kgC/indiv] - real(r8) :: b_stem_carb ! aboveground stem biomass in carbon units [kgC/indiv] - real(r8) :: b_stem_biom ! aboveground stem biomass in dry wt units [kg/indiv] - real(r8) :: b_bg_carb ! belowground biomass (coarse + fine roots) in carbon units [kgC/indiv] - real(r8) :: b_tot_carb ! total individual biomass in carbon units [kgC/indiv] - real(r8) :: v_stem ! aboveground stem volume [m3/indiv] - real(r8) :: z_stem ! the height of the plants stem below crown [m] - real(r8) :: sla ! specific leaf area [cm2/g] - real(r8) :: v_canopy ! total leaf (canopy) volume [m3/indiv] - real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] - real(r8) :: a_sapwood ! sapwood area [m2] - real(r8) :: a_sapwood_target ! sapwood cross-section area at reference height, at target biomass [m2] - real(r8) :: bsw_target ! sapwood carbon, at target [kgC] - real(r8) :: v_sapwood ! sapwood volume [m3] - real(r8) :: b_troot_carb ! transporting root biomass in carbon units [kgC/indiv] - real(r8) :: b_troot_biom ! transporting root biomass in dry wt units [kg/indiv] - real(r8) :: v_troot ! transporting root volume [m3/indiv] - real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] - real(r8) :: crown_depth ! Depth of the plant's crown [m] - real(r8) :: kmax_node1_nodekplus1(n_hypool_ag) ! cumulative kmax, petiole to node k+1, - ! conduit taper effects excluded [kg s-1 MPa-1] - real(r8) :: kmax_node1_lowerk(n_hypool_ag) ! cumulative kmax, petiole to upper boundary of node k, - ! conduit taper effects excluded [kg s-1 MPa-1] - real(r8) :: chi_node1_nodekplus1(n_hypool_ag) ! ratio of cumulative kmax with taper effects - ! included to that without [-] - real(r8) :: chi_node1_lowerk(n_hypool_ag) ! ratio of cumulative kmax with taper effects - ! included to that without [-] - real(r8) :: dz_node1_nodekplus1 ! cumulative distance between canopy - ! node and node k + 1 [m] - real(r8) :: dz_node1_lowerk ! cumulative distance between canopy - ! node and upper boundary of node k [m] - real(r8) :: kmax_treeag_tot ! total stem (petiole to transporting root node) - ! hydraulic conductance [kg s-1 MPa-1] - real(r8) :: kmax_tot ! total tree (leaf to root tip) - ! hydraulic conductance [kg s-1 MPa-1] - real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] - - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft - - leaf_c = ccohort%prt%GetState(leaf_organ, all_carbon_elements) - sapw_c = ccohort%prt%GetState(sapw_organ, all_carbon_elements) - fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) - struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) - - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) - - !roota = 4.372_r8 ! TESTING: deep (see Zeng 2001 Table 1) - !rootb = 0.978_r8 ! TESTING: deep (see Zeng 2001 Table 1) - !roota = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) - !rootb = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) - - if(leaf_c > 0._r8) then - - - ! ------------------------------------------------------------------------------ - ! Part 1. Set the volumes of the leaf, stem and root compartments - ! and lenghts of the roots - ! ------------------------------------------------------------------------------ - - b_woody_carb = sapw_c + struct_c - b_woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_woody_carb - b_tot_carb = sapw_c + struct_c + leaf_c + fnrt_c - b_canopy_carb = leaf_c - b_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_tot_carb - b_canopy_biom = b_canopy_carb * C2B - - ! NOTE: SLATOP currently does not use any vertical scaling functions - ! but that may not be so forever. ie sla = slatop (RGK-082017) - ! m2/gC * cm2/m2 -> cm2/gC - sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 - - ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/C2B + 781.899_r8 - v_canopy = b_canopy_biom / denleaf - - ccohort_hydr%v_ag(1:n_hypool_leaf) = v_canopy / real(n_hypool_leaf,r8) - - - b_stem_carb = b_tot_carb - b_bg_carb - b_canopy_carb - b_stem_biom = b_stem_carb * C2B ! kg DM - - !BOC...may be needed for testing/comparison w/ v_sapwood - ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 - v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8 ) - - ! calculate the sapwood cross-sectional area - call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,bsw_target) - a_sapwood = a_sapwood_target - - ! Alternative ways to calculate sapwood cross section - ! or .... - ! a_sapwood = a_sapwood_target * ccohort%bsw / bsw_target - - ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(ft)*1.e-4_r8 - ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 - ! or ... - !a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - - call CrownDepth(ccohort%hite,crown_depth) - z_stem = ccohort%hite - crown_depth - v_sapwood = a_sapwood * z_stem - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem - - - ! Determine belowground biomass as a function of total (sapwood, heartwood, - ! leaf, fine root) biomass then subtract out the fine root biomass to get - ! coarse (transporting) root biomass - - b_troot_carb = b_woody_bg_carb - b_troot_biom = b_troot_carb * C2B - v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8) - - !! BOC not sure if/how we should multiply this by the sapwood fraction - ccohort_hydr%v_troot(:) = v_troot / n_hypool_troot - - - ! Estimate absorbing root total length (all layers) - ! ------------------------------------------------------------------------------ - ccohort_hydr%l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(ft) - - ! Estimate absorbing root volume (all layers) - ! ------------------------------------------------------------------------------ - ccohort_hydr%v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & - ccohort_hydr%l_aroot_tot - - - ! Partition the total absorbing root lengths and volumes into the active soil layers - ! ------------------------------------------------------------------------------ - if(nlevsoi_hyd == 1) then - ccohort_hydr%l_aroot_layer(nlevsoi_hyd) = ccohort_hydr%l_aroot_tot - ccohort_hydr%v_aroot_layer(nlevsoi_hyd) = ccohort_hydr%v_aroot_tot - else - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%l_aroot_layer(j) = rootfr*ccohort_hydr%l_aroot_tot - ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot - end do - end if - - - ! ------------------------------------------------------------------------------ - ! Part II. Set maximum (size-dependent) hydraulic conductances - ! ------------------------------------------------------------------------------ - - ! first estimate cumulative (petiole to node k) conductances - ! without taper as well as the chi taper function - - do k=n_hypool_leaf,n_hypool_ag - dz_node1_lowerk = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_lower_ag(k) - if(k < n_hypool_ag) then - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_ag(k+1) - else - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_troot(1) - end if - kmax_node1_nodekplus1(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_nodekplus1 - kmax_node1_lowerk(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_lowerk - chi_node1_nodekplus1(k) = xylemtaper(taper_exponent, dz_node1_nodekplus1) - chi_node1_lowerk(k) = xylemtaper(taper_exponent, dz_node1_lowerk) - if(.not.do_kbound_upstream) then - if(crown_depth == 0._r8) then - write(fates_log(),*) 'do_kbound_upstream requires a nonzero canopy depth ' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - enddo - - - ! then calculate the conductances at node boundaries as the difference of cumulative conductances - do k=n_hypool_leaf,n_hypool_ag - if(k == n_hypool_leaf) then - ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) - ccohort_hydr%kmax_lower(k) = kmax_node1_lowerk(k) * chi_node1_lowerk(k) - else - ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - ccohort_hydr%kmax_lower(k) = ( 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) - & - 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - end if - if(k < n_hypool_ag) then - ccohort_hydr%kmax_upper(k+1) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) - else if(k == n_hypool_ag) then - ccohort_hydr%kmax_upper_troot = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) - end if - - !!!!!!!!!! FOR TESTING ONLY - !ccohort_hydr%kmax_bound(:) = 0.02_r8 ! Diurnal lwp variation in coldstart: -0.1 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: less than -0.01 MPa - !ccohort_hydr%kmax_bound(:) = 0.0016_r8 ! Diurnal lwp variation in coldstart: -0.8 - 1.0 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -1.5 - 2.0 MPa [seemingly unstable] - !ccohort_hydr%kmax_bound(:) = 0.0008_r8 ! Diurnal lwp variation in coldstart: -1.5 - 2.0 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -2.0 - 3.0 MPa [seemingly unstable] - !ccohort_hydr%kmax_bound(:) = 0.0005_r8 ! Diurnal lwp variation in coldstart: -2.0 - 3.0 MPa and one -5 MPa outlier - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -3.0 - 4.0 MPa and one -10 MPa outlier [Unstable] - !!!!!!!!!! - - enddo - - ! finally, estimate the remaining tree conductance belowground as a residual - kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))**(-1._r8) - kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft) * kmax_treeag_tot - ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) - - if(nlevsoi_hyd == 1) then - ccohort_hydr%kmax_treebg_layer(:) = ccohort_hydr%kmax_treebg_tot * & - ccohort%patchptr%rootfr_ft(ft,:) - else - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot - end do - end if - - end if !check for bleaf - - end subroutine UpdateTreeHydrLenVolCond - - - - !===================================================================================== - subroutine UpdateWaterDepTreeHydrCond(currentSite,ccohort,nlevsoi_hyd,bc_in) - - ! ----------------------------------------------------------------------------------- - ! This subroutine calculates update the conductivity for the soil-root interface, - ! depending on the plant water uptake/loss. - ! we assume that the conductivitity for water uptake is larger than - ! water loss due to composite regulation of resistance the roots - ! hydraulic vs osmostic with and without transpiration - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! ----------------------------------------------------------------------------------- - - ! Arguments - type(ed_site_type) , intent(in) :: currentSite ! Site target - type(ed_cohort_type),intent(inout) :: ccohort ! cohort target - integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions - - type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure - type(ed_site_hydr_type),pointer :: csite_hydr - - integer :: j,k - real(r8) :: hksat_s ! hksat converted to units of 10^6sec - real(r8) :: kmax_root_surf_total ! maximum conducitivity for total root surface(kg water/Mpa/s) - real(r8) :: kmax_soil_total ! maximum conducitivity for from root surface to soil shell(kg water/Mpa/s) - ! which is equiv to [kg m-1 s-1 MPa-1] - real(r8) :: kmax_root_surf ! maximum conducitivity for unit root surface (kg water/m2 root area/Mpa/s) - - ccohort_hydr => ccohort%co_hydr - csite_hydr => currentSite%si_hydr - k = 1 !only for the first soil shell - do j=1, nlevsoi_hyd - - hksat_s = bc_in%hksat_sisl(j) * 1.e-3_r8 * 1/grav * 1.e6_r8 - if(ccohort_hydr%psi_aroot(j) ccohort%co_hydr + ft = ccohort%pft + + leaf_c = ccohort%prt%GetState(leaf_organ, all_carbon_elements) + sapw_c = ccohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) + struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) + + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) + + !roota = 4.372_r8 ! TESTING: deep (see Zeng 2001 Table 1) + !rootb = 0.978_r8 ! TESTING: deep (see Zeng 2001 Table 1) + !roota = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) + !rootb = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) + + if(leaf_c > 0._r8) then + + + ! ------------------------------------------------------------------------------ + ! Part 1. Set the volumes of the leaf, stem and root compartments + ! and lenghts of the roots + ! ------------------------------------------------------------------------------ + + b_woody_carb = sapw_c + struct_c + b_woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_woody_carb + b_tot_carb = sapw_c + struct_c + leaf_c + fnrt_c + b_canopy_carb = leaf_c + b_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_tot_carb + b_canopy_biom = b_canopy_carb * C2B + + ! NOTE: SLATOP currently does not use any vertical scaling functions + ! but that may not be so forever. ie sla = slatop (RGK-082017) + ! m2/gC * cm2/m2 -> cm2/gC + sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 + + ! empirical regression data from leaves at Caxiuana (~ 8 spp) + denleaf = -2.3231_r8*sla/C2B + 781.899_r8 + v_canopy = b_canopy_biom / denleaf + + ccohort_hydr%v_ag(1:n_hypool_leaf) = v_canopy / real(n_hypool_leaf,r8) + + + b_stem_carb = b_tot_carb - b_bg_carb - b_canopy_carb + b_stem_biom = b_stem_carb * C2B ! kg DM + + !BOC...may be needed for testing/comparison w/ v_sapwood + ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 + v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8 ) + + ! calculate the sapwood cross-sectional area + call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,bsw_target) + a_sapwood = a_sapwood_target + + ! Alternative ways to calculate sapwood cross section + ! or .... + ! a_sapwood = a_sapwood_target * ccohort%bsw / bsw_target + + ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(ft)*1.e-4_r8 + ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 + ! or ... + !a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 + + call CrownDepth(ccohort%hite,crown_depth) + z_stem = ccohort%hite - crown_depth + v_sapwood = a_sapwood * z_stem + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem + + + ! Determine belowground biomass as a function of total (sapwood, heartwood, + ! leaf, fine root) biomass then subtract out the fine root biomass to get + ! coarse (transporting) root biomass + + b_troot_carb = b_woody_bg_carb + b_troot_biom = b_troot_carb * C2B + v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8) + + !! BOC not sure if/how we should multiply this by the sapwood fraction + ccohort_hydr%v_troot(:) = v_troot / n_hypool_troot + + + ! Estimate absorbing root total length (all layers) + ! ------------------------------------------------------------------------------ + ccohort_hydr%l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(ft) + + ! Estimate absorbing root volume (all layers) + ! ------------------------------------------------------------------------------ + ccohort_hydr%v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & + ccohort_hydr%l_aroot_tot + + + ! Partition the total absorbing root lengths and volumes into the active soil layers + ! ------------------------------------------------------------------------------ + if(nlevsoi_hyd == 1) then + ccohort_hydr%l_aroot_layer(nlevsoi_hyd) = ccohort_hydr%l_aroot_tot + ccohort_hydr%v_aroot_layer(nlevsoi_hyd) = ccohort_hydr%v_aroot_tot + else + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + ccohort_hydr%l_aroot_layer(j) = rootfr*ccohort_hydr%l_aroot_tot + ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot + end do + end if + + + ! ------------------------------------------------------------------------------ + ! Part II. Set maximum (size-dependent) hydraulic conductances + ! ------------------------------------------------------------------------------ + + ! first estimate cumulative (petiole to node k) conductances + ! without taper as well as the chi taper function + + do k=n_hypool_leaf,n_hypool_ag + dz_node1_lowerk = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_lower_ag(k) + if(k < n_hypool_ag) then + dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_node_ag(k+1) + else + dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_node_troot(1) + end if + kmax_node1_nodekplus1(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_nodekplus1 + kmax_node1_lowerk(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_lowerk + chi_node1_nodekplus1(k) = xylemtaper(taper_exponent, dz_node1_nodekplus1) + chi_node1_lowerk(k) = xylemtaper(taper_exponent, dz_node1_lowerk) + if(.not.do_kbound_upstream) then + if(crown_depth == 0._r8) then + write(fates_log(),*) 'do_kbound_upstream requires a nonzero canopy depth ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + enddo + + + ! then calculate the conductances at node boundaries as the difference of cumulative conductances + do k=n_hypool_leaf,n_hypool_ag + if(k == n_hypool_leaf) then + ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) + ccohort_hydr%kmax_lower(k) = kmax_node1_lowerk(k) * chi_node1_lowerk(k) + else + ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & + 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) + ccohort_hydr%kmax_lower(k) = ( 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) - & + 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) + end if + if(k < n_hypool_ag) then + ccohort_hydr%kmax_upper(k+1) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & + 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) + else if(k == n_hypool_ag) then + ccohort_hydr%kmax_upper_troot = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & + 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) + end if + +!!!!!!!!!! FOR TESTING ONLY + !ccohort_hydr%kmax_bound(:) = 0.02_r8 ! Diurnal lwp variation in coldstart: -0.1 MPa + ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: less than -0.01 MPa + !ccohort_hydr%kmax_bound(:) = 0.0016_r8 ! Diurnal lwp variation in coldstart: -0.8 - 1.0 MPa + ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -1.5 - 2.0 MPa [seemingly unstable] + !ccohort_hydr%kmax_bound(:) = 0.0008_r8 ! Diurnal lwp variation in coldstart: -1.5 - 2.0 MPa + ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -2.0 - 3.0 MPa [seemingly unstable] + !ccohort_hydr%kmax_bound(:) = 0.0005_r8 ! Diurnal lwp variation in coldstart: -2.0 - 3.0 MPa and one -5 MPa outlier + ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -3.0 - 4.0 MPa and one -10 MPa outlier [Unstable] +!!!!!!!!!! + + enddo + + ! finally, estimate the remaining tree conductance belowground as a residual + kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))**(-1._r8) + kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft) * kmax_treeag_tot + ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) + + if(nlevsoi_hyd == 1) then + ccohort_hydr%kmax_treebg_layer(:) = ccohort_hydr%kmax_treebg_tot * & + ccohort%patchptr%rootfr_ft(ft,:) + else + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot + end do + end if + + end if !check for bleaf + + end subroutine UpdateTreeHydrLenVolCond + + + !===================================================================================== + + subroutine KmaxInnerShell(currentSite, ccohort, hksat_soil, kmax_innershell) + + ! ----------------------------------------------------------------------------------- + ! This subroutine calculates update the conductance across the soil to root + ! interface depending on the plant water uptake/loss. + ! we assume that the conductivitity for water uptake is larger than + ! water loss due to composite regulation of resistance the roots + ! hydraulic vs osmostic with and without transpiration. + ! + ! Output: conductance at soil-root inerface (each layer): + ! ccohort_hydr%kmax_innershell(j) [kg s-1 MPa-1 ] + + ! Consider M Williams et al. 1996 + ! Consider Kennedy et al. 2019 + ! https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2018MS001500 + ! + ! flux = conductance * area * (delta psi + delta z) + ! + ! + + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! ----------------------------------------------------------------------------------- + + ! Arguments + type(ed_site_type) , intent(in) :: currentSite ! Site target + type(ed_cohort_type),intent(inout) :: ccohort ! cohort target + real(r8),intent(in) :: hksat_soil(:) ! Saturated Hydraulic conductivity + ! of the soil [mm H2O s-1] + real(r8),intent(out) :: kmax_innershell(:) + + type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure + type(ed_site_hydr_type),pointer :: csite_hydr + + integer :: j ! loop index for soil layers + real(r8) :: hksat_s ! hydraulic conductivity at saturation [kg s-1 MPa-1] + + ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] + ! + ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 + ! + ! [mm s-1] * 1e-3 [m mm-1] + ! * 1 [kg m-1 s-2 Pa-1] + ! * 9.8-1 [s2 m-1] + ! * 1e6 [Pa MPa-1] + ! = [kg s-1 m-1 MPa-1] + real(r8) :: kmax_root_surf_total ! maximum conducitivity for total + ! root surface [kg MPa-1 s-1] + real(r8) :: kmax_soil_total ! maximum conducitivity for from root + ! surface to soil shell(kg water/Mpa/s) + ! which is equiv to [kg m-1 s-1 MPa-1] + real(r8) :: kmax_root_surf ! maximum conducitivity for unit root + ! surface (kg water/m2 root area/Mpa/s) + + integer, parameter :: k_inner = 1 ! index for the inner rhizosphere shell (closest to root) + logical, parameter :: use_kmax_rootsurf_smoothing = .false. ! If this is true, use a root surface conductivity + ! that is a linear function of the potential ratio of + ! the absorbing root and the inner shell + + + ccohort_hydr => ccohort%co_hydr + csite_hydr => currentSite%si_hydr + + do j=1, csite_hydr%nlevsoi_hyd + + hksat_s = hksat_soil(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa + + psi_ratio = ccohort_hydr%psi_aroot(j)/csite_hydr%psisoi_liq_innershell(j) + + if(use_kmax_rootsurf_smoothing) then + + psi_ratio = ccohort_hydr%psi_aroot(j)/csite_hydr%psisoi_liq_innershell(j) + + ! if psi_ratio > 1.5, then the root is pretty dry compared to the soil + ! and we use the hydr_kmax_rsurf1. If it below 0.667, then the soil + ! is pretty dry compared to root, and use hydr_kmax_rsurf2 + + slope = (hydr_kmax_rsurf1-hydr_kmax_rsurf2)/(1.5-0.666) + + kmax_root_surf = hydr_kmax_rsurf2 + min(hydr_kmax_rsurf1,max(0._r8,(psi_ratio-0.666)*slope)) + + + else + if(ccohort_hydr%psi_aroot(j) root radius + ! then we use a harmonic average of the max root surface and soil + ! conductance - ccohort_hydr%kmax_innershell(j) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**(-1._r8) - end if - end do - - end subroutine UpdateWaterDepTreeHydrCond + else + + ! A = L*2*Pi / log(r_shell/r_root) * [kg s-1 m-1 MPa-1] + + kmax_soil_total = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + + kmax_innershell(j) = (1._r8/kmax_root_surf_total + & + 1._r8/kmax_soil_total)**(-1._r8) + end if + end do + + end subroutine KmaxInnerShell ! ===================================================================================== + subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! ! !DESCRIPTION: @@ -933,9 +987,9 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! !USES: use FatesUtilsMod , only : check_var_real use EDTypesMod , only : AREA - + ! !ARGUMENTS: - type(ed_site_type) , intent(in) :: currentSite ! Site stuff + type(ed_site_type) , intent(in) :: currentSite ! Site stuff type(ed_cohort_type) , intent(inout) :: ccohort ! ! !LOCAL VARIABLES: @@ -952,7 +1006,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft - + ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) @@ -960,39 +1014,39 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself -- apply water mass conservation) do k=1,n_hypool_ag th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & - ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) + ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, k) enddo do k=1,n_hypool_troot th_troot_uncorr(k) = ccohort_hydr%th_troot(k) * & - ccohort_hydr%v_troot_init(k) /ccohort_hydr%v_troot(k) + ccohort_hydr%v_troot_init(k) /ccohort_hydr%v_troot(k) ccohort_hydr%th_troot(k) = constrain_water_contents(th_troot_uncorr(k), small_theta_num, ft, 3) enddo do j=1,currentSite%si_hydr%nlevsoi_hyd th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & - ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) + ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) ccohort_hydr%errh2o_growturn_aroot(j) = ccohort_hydr%th_aroot(j) - th_aroot_uncorr(j) enddo - + ! Storing mass balance error ! + means water created; - means water destroyed ccohort_hydr%errh2o_growturn_ag(:) = ccohort_hydr%th_ag(:) - th_ag_uncorr(:) ccohort_hydr%errh2o_growturn_troot(:) = ccohort_hydr%th_troot(:) - th_troot_uncorr(:) csite_hydr =>currentSite%si_hydr csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & - (sum(ccohort_hydr%errh2o_growturn_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%errh2o_growturn_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%errh2o_growturn_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*cCohort%n/AREA - + (sum(ccohort_hydr%errh2o_growturn_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%errh2o_growturn_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%errh2o_growturn_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*cCohort%n/AREA + ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 - + end subroutine updateSizeDepTreeHydStates -! ===================================================================================== - + ! ===================================================================================== + function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) ! !ARGUMENTS: @@ -1018,237 +1072,237 @@ function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) end function constrain_water_contents ! ===================================================================================== - subroutine CopyCohortHydraulics(newCohort, oldCohort) - - ! Arguments - type(ed_cohort_type), intent(inout), target :: newCohort - type(ed_cohort_type), intent(inout), target :: oldCohort - - ! Locals - type(ed_cohort_hydr_type), pointer :: ncohort_hydr - type(ed_cohort_hydr_type), pointer :: ocohort_hydr - - - ncohort_hydr => newCohort%co_hydr - ocohort_hydr => oldCohort%co_hydr - - - ! BC...PLANT HYDRAULICS - "constants" that change with size. - ! Heights are referenced to soil surface (+ = above; - = below) - ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag - ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot - ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag - ncohort_hydr%z_upper_troot = ocohort_hydr%z_upper_troot - ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag - ncohort_hydr%z_lower_troot = ocohort_hydr%z_lower_troot - ncohort_hydr%kmax_upper = ocohort_hydr%kmax_upper - ncohort_hydr%kmax_lower = ocohort_hydr%kmax_lower - ncohort_hydr%kmax_upper_troot = ocohort_hydr%kmax_upper_troot - ncohort_hydr%kmax_bound = ocohort_hydr%kmax_bound - ncohort_hydr%kmax_treebg_tot = ocohort_hydr%kmax_treebg_tot - ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init - ncohort_hydr%v_ag = ocohort_hydr%v_ag - ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init - ncohort_hydr%v_troot = ocohort_hydr%v_troot - ncohort_hydr%v_aroot_tot = ocohort_hydr%v_aroot_tot - ncohort_hydr%l_aroot_tot = ocohort_hydr%l_aroot_tot - ! quantities indexed by soil layer - ncohort_hydr%z_node_aroot = ocohort_hydr%z_node_aroot - ncohort_hydr%kmax_treebg_layer = ocohort_hydr%kmax_treebg_layer - ncohort_hydr%kmax_innershell = ocohort_hydr%kmax_innershell - ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init - ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer - ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer - - ! BC PLANT HYDRAULICS - state variables - ncohort_hydr%th_ag = ocohort_hydr%th_ag - ncohort_hydr%th_troot = ocohort_hydr%th_troot - ncohort_hydr%psi_ag = ocohort_hydr%psi_ag - ncohort_hydr%psi_troot = ocohort_hydr%psi_troot - ncohort_hydr%flc_ag = ocohort_hydr%flc_ag - ncohort_hydr%flc_troot = ocohort_hydr%flc_troot - ncohort_hydr%flc_min_ag = ocohort_hydr%flc_min_ag - - ncohort_hydr%flc_min_troot = ocohort_hydr%flc_min_troot - - !refilling status--these are constants are should be moved the fates parameter file(Chonggang XU) - ncohort_hydr%refill_thresh = ocohort_hydr%refill_thresh - ncohort_hydr%refill_days = ocohort_hydr%refill_days - ncohort_hydr%btran = ocohort_hydr%btran - - ncohort_hydr%lwp_mem = ocohort_hydr%lwp_mem - ncohort_hydr%lwp_stable = ocohort_hydr%lwp_stable - ncohort_hydr%lwp_is_unstable = ocohort_hydr%lwp_is_unstable - ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag - - ncohort_hydr%iterh1 = ocohort_hydr%iterh1 - ncohort_hydr%iterh2 = ocohort_hydr%iterh2 - ncohort_hydr%errh2o = ocohort_hydr%errh2o - ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag - - - - - - - ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag - - - - ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot - ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot - ! quantities indexed by soil layer - ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - !ncohort_hydr%th_aroot_prev = ocohort_hydr%th_aroot_prev - !ncohort_hydr%th_aroot_prev_uncorr = ocohort_hydr%th_aroot_prev_uncorr - ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%flc_aroot = ocohort_hydr%flc_aroot - ncohort_hydr%flc_min_aroot = ocohort_hydr%flc_min_aroot - - ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot - ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot - - ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%qtop_dt = ocohort_hydr%qtop_dt - ncohort_hydr%dqtopdth_dthdt = ocohort_hydr%dqtopdth_dthdt - - ncohort_hydr%sapflow = ocohort_hydr%sapflow - ncohort_hydr%rootuptake = ocohort_hydr%rootuptake - ncohort_hydr%rootuptake01 = ocohort_hydr%rootuptake01 - ncohort_hydr%rootuptake02 = ocohort_hydr%rootuptake02 - ncohort_hydr%rootuptake03 = ocohort_hydr%rootuptake03 - ncohort_hydr%rootuptake04 = ocohort_hydr%rootuptake04 - ncohort_hydr%rootuptake05 = ocohort_hydr%rootuptake05 - ncohort_hydr%rootuptake06 = ocohort_hydr%rootuptake06 - ncohort_hydr%rootuptake07 = ocohort_hydr%rootuptake07 - ncohort_hydr%rootuptake08 = ocohort_hydr%rootuptake08 - ncohort_hydr%rootuptake09 = ocohort_hydr%rootuptake09 - ncohort_hydr%rootuptake10 = ocohort_hydr%rootuptake10 - - ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited + subroutine CopyCohortHydraulics(newCohort, oldCohort) + + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort + + ! Locals + type(ed_cohort_hydr_type), pointer :: ncohort_hydr + type(ed_cohort_hydr_type), pointer :: ocohort_hydr + + + ncohort_hydr => newCohort%co_hydr + ocohort_hydr => oldCohort%co_hydr + + + ! BC...PLANT HYDRAULICS - "constants" that change with size. + ! Heights are referenced to soil surface (+ = above; - = below) + ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag + ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot + ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag + ncohort_hydr%z_upper_troot = ocohort_hydr%z_upper_troot + ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag + ncohort_hydr%z_lower_troot = ocohort_hydr%z_lower_troot + ncohort_hydr%kmax_upper = ocohort_hydr%kmax_upper + ncohort_hydr%kmax_lower = ocohort_hydr%kmax_lower + ncohort_hydr%kmax_upper_troot = ocohort_hydr%kmax_upper_troot + ncohort_hydr%kmax_bound = ocohort_hydr%kmax_bound + ncohort_hydr%kmax_treebg_tot = ocohort_hydr%kmax_treebg_tot + ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init + ncohort_hydr%v_ag = ocohort_hydr%v_ag + ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init + ncohort_hydr%v_troot = ocohort_hydr%v_troot + ncohort_hydr%v_aroot_tot = ocohort_hydr%v_aroot_tot + ncohort_hydr%l_aroot_tot = ocohort_hydr%l_aroot_tot + ! quantities indexed by soil layer + ncohort_hydr%z_node_aroot = ocohort_hydr%z_node_aroot + ncohort_hydr%kmax_treebg_layer = ocohort_hydr%kmax_treebg_layer + ncohort_hydr%kmax_innershell = ocohort_hydr%kmax_innershell + ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init + ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer + ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer + + ! BC PLANT HYDRAULICS - state variables + ncohort_hydr%th_ag = ocohort_hydr%th_ag + ncohort_hydr%th_troot = ocohort_hydr%th_troot + ncohort_hydr%psi_ag = ocohort_hydr%psi_ag + ncohort_hydr%psi_troot = ocohort_hydr%psi_troot + ncohort_hydr%flc_ag = ocohort_hydr%flc_ag + ncohort_hydr%flc_troot = ocohort_hydr%flc_troot + ncohort_hydr%flc_min_ag = ocohort_hydr%flc_min_ag + + ncohort_hydr%flc_min_troot = ocohort_hydr%flc_min_troot + + !refilling status--these are constants are should be moved the fates parameter file(Chonggang XU) + ncohort_hydr%refill_thresh = ocohort_hydr%refill_thresh + ncohort_hydr%refill_days = ocohort_hydr%refill_days + ncohort_hydr%btran = ocohort_hydr%btran + + ncohort_hydr%lwp_mem = ocohort_hydr%lwp_mem + ncohort_hydr%lwp_stable = ocohort_hydr%lwp_stable + ncohort_hydr%lwp_is_unstable = ocohort_hydr%lwp_is_unstable + ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag + + ncohort_hydr%iterh1 = ocohort_hydr%iterh1 + ncohort_hydr%iterh2 = ocohort_hydr%iterh2 + ncohort_hydr%errh2o = ocohort_hydr%errh2o + ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag + + + + + + + ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag + + + + ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot + ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot + ! quantities indexed by soil layer + ncohort_hydr%th_aroot = ocohort_hydr%th_aroot + !ncohort_hydr%th_aroot_prev = ocohort_hydr%th_aroot_prev + !ncohort_hydr%th_aroot_prev_uncorr = ocohort_hydr%th_aroot_prev_uncorr + ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot + ncohort_hydr%flc_aroot = ocohort_hydr%flc_aroot + ncohort_hydr%flc_min_aroot = ocohort_hydr%flc_min_aroot + + ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot + ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot + + ! BC PLANT HYDRAULICS - flux terms + ncohort_hydr%qtop_dt = ocohort_hydr%qtop_dt + ncohort_hydr%dqtopdth_dthdt = ocohort_hydr%dqtopdth_dthdt + + ncohort_hydr%sapflow = ocohort_hydr%sapflow + ncohort_hydr%rootuptake = ocohort_hydr%rootuptake + ncohort_hydr%rootuptake01 = ocohort_hydr%rootuptake01 + ncohort_hydr%rootuptake02 = ocohort_hydr%rootuptake02 + ncohort_hydr%rootuptake03 = ocohort_hydr%rootuptake03 + ncohort_hydr%rootuptake04 = ocohort_hydr%rootuptake04 + ncohort_hydr%rootuptake05 = ocohort_hydr%rootuptake05 + ncohort_hydr%rootuptake06 = ocohort_hydr%rootuptake06 + ncohort_hydr%rootuptake07 = ocohort_hydr%rootuptake07 + ncohort_hydr%rootuptake08 = ocohort_hydr%rootuptake08 + ncohort_hydr%rootuptake09 = ocohort_hydr%rootuptake09 + ncohort_hydr%rootuptake10 = ocohort_hydr%rootuptake10 + + ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited end subroutine CopyCohortHydraulics - + ! ===================================================================================== subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) - - type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort - type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort - type(ed_site_type), intent(inout), target :: currentSite ! current site - - type(bc_in_type), intent(in) :: bc_in - real(r8), intent(in) :: newn - - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type - type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type - integer :: j,k ! indices - - site_hydr => currentSite%si_hydr - - ccohort_hydr => currentCohort%co_hydr - ncohort_hydr => nextCohort%co_hydr - - ccohort_hydr%th_ag(:) = (currentCohort%n*ccohort_hydr%th_ag(:) + & - nextCohort%n*ncohort_hydr%th_ag(:))/newn - ccohort_hydr%th_troot(:) = (currentCohort%n*ccohort_hydr%th_troot(:) + & - nextCohort%n*ncohort_hydr%th_troot(:))/newn - ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & - nextCohort%n*ncohort_hydr%th_aroot(:))/newn - ccohort_hydr%supsub_flag = 0._r8 - ccohort_hydr%iterh1 = 0._r8 - ccohort_hydr%iterh2 = 0._r8 - - do k=1,n_hypool_ag - call psi_from_th(currentCohort%pft, porous_media(k), ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k), site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%flc_ag(k), site_hydr, bc_in) - end do - do k=n_hypool_ag+1,n_hypool_ag+n_hypool_troot - call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot(k-n_hypool_ag), & - ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, 3, ccohort_hydr%psi_troot(k-n_hypool_ag), & - ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in) - end do - do j=1,site_hydr%nlevsoi_hyd - call psi_from_th(currentCohort%pft, 4, ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j), site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, 4, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%flc_aroot(j), site_hydr, bc_in) - end do - call flc_gs_from_psi(currentCohort, ccohort_hydr%psi_ag(1)) - ccohort_hydr%qtop_dt = (currentCohort%n*ccohort_hydr%qtop_dt + & - nextCohort%n*ncohort_hydr%qtop_dt)/newn - ccohort_hydr%dqtopdth_dthdt = (currentCohort%n*ccohort_hydr%dqtopdth_dthdt + & - nextCohort%n*ncohort_hydr%dqtopdth_dthdt)/newn - ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & - nextCohort%n*ncohort_hydr%sapflow)/newn - ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & - nextCohort%n*ncohort_hydr%rootuptake)/newn - ccohort_hydr%rootuptake01 = (currentCohort%n*ccohort_hydr%rootuptake01 + & - nextCohort%n*ncohort_hydr%rootuptake01)/newn - ccohort_hydr%rootuptake02 = (currentCohort%n*ccohort_hydr%rootuptake02 + & - nextCohort%n*ncohort_hydr%rootuptake02)/newn - ccohort_hydr%rootuptake03 = (currentCohort%n*ccohort_hydr%rootuptake03 + & - nextCohort%n*ncohort_hydr%rootuptake03)/newn - ccohort_hydr%rootuptake04 = (currentCohort%n*ccohort_hydr%rootuptake04 + & - nextCohort%n*ncohort_hydr%rootuptake04)/newn - ccohort_hydr%rootuptake05 = (currentCohort%n*ccohort_hydr%rootuptake05 + & - nextCohort%n*ncohort_hydr%rootuptake05)/newn - ccohort_hydr%rootuptake06 = (currentCohort%n*ccohort_hydr%rootuptake06 + & - nextCohort%n*ncohort_hydr%rootuptake06)/newn - ccohort_hydr%rootuptake07 = (currentCohort%n*ccohort_hydr%rootuptake07 + & - nextCohort%n*ncohort_hydr%rootuptake07)/newn - ccohort_hydr%rootuptake08 = (currentCohort%n*ccohort_hydr%rootuptake08 + & - nextCohort%n*ncohort_hydr%rootuptake08)/newn - ccohort_hydr%rootuptake09 = (currentCohort%n*ccohort_hydr%rootuptake09 + & - nextCohort%n*ncohort_hydr%rootuptake09)/newn - ccohort_hydr%rootuptake10 = (currentCohort%n*ccohort_hydr%rootuptake10 + & - nextCohort%n*ncohort_hydr%rootuptake10)/newn - - ccohort_hydr%lwp_mem(:) = ccohort_hydr%psi_ag(1) - ccohort_hydr%lwp_stable = ccohort_hydr%psi_ag(1) - ccohort_hydr%lwp_is_unstable = .false. - ccohort_hydr%flc_min_ag(:) = (currentCohort%n*ccohort_hydr%flc_min_ag(:) + & - nextCohort%n*ncohort_hydr%flc_min_ag(:))/newn - ccohort_hydr%flc_min_troot(:) = (currentCohort%n*ccohort_hydr%flc_min_troot(:) + & - nextCohort%n*ncohort_hydr%flc_min_troot(:))/newn - ccohort_hydr%flc_min_aroot(:) = (currentCohort%n*ccohort_hydr%flc_min_aroot(:) + & - nextCohort%n*ncohort_hydr%flc_min_aroot(:))/newn - - ! need to be migrated to parmeter file (BOC 07/24/2018) - ccohort_hydr%refill_thresh = -0.01_r8 - ccohort_hydr%refill_days = 3.0_r8 - - ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & - nextCohort%n*ncohort_hydr%errh2o)/newn - ccohort_hydr%errh2o_growturn_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_ag(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_ag(:))/newn - ccohort_hydr%errh2o_pheno_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_ag(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_ag(:))/newn - ccohort_hydr%errh2o_growturn_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_troot(:))/newn - ccohort_hydr%errh2o_pheno_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_troot(:))/newn - ccohort_hydr%errh2o_growturn_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_aroot(:))/newn - ccohort_hydr%errh2o_pheno_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_aroot(:))/newn - - !ccohort_hydr%th_aroot_prev(:) - !ccohort_hydr%th_aroot_prev_uncorr(:) - - ccohort_hydr%is_newly_recruited = .false. - end subroutine FuseCohortHydraulics + type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort + type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort + type(ed_site_type), intent(inout), target :: currentSite ! current site + + type(bc_in_type), intent(in) :: bc_in + real(r8), intent(in) :: newn + + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: site_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type + type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type + integer :: j,k ! indices + + site_hydr => currentSite%si_hydr + + ccohort_hydr => currentCohort%co_hydr + ncohort_hydr => nextCohort%co_hydr + + ccohort_hydr%th_ag(:) = (currentCohort%n*ccohort_hydr%th_ag(:) + & + nextCohort%n*ncohort_hydr%th_ag(:))/newn + ccohort_hydr%th_troot(:) = (currentCohort%n*ccohort_hydr%th_troot(:) + & + nextCohort%n*ncohort_hydr%th_troot(:))/newn + ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & + nextCohort%n*ncohort_hydr%th_aroot(:))/newn + ccohort_hydr%supsub_flag = 0._r8 + ccohort_hydr%iterh1 = 0._r8 + ccohort_hydr%iterh2 = 0._r8 + + do k=1,n_hypool_ag + call psi_from_th(currentCohort%pft, porous_media(k), ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k), site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & + ccohort_hydr%flc_ag(k), site_hydr, bc_in) + end do + do k=n_hypool_ag+1,n_hypool_ag+n_hypool_troot + call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot(k-n_hypool_ag), & + ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, 3, ccohort_hydr%psi_troot(k-n_hypool_ag), & + ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in) + end do + do j=1,site_hydr%nlevsoi_hyd + call psi_from_th(currentCohort%pft, 4, ccohort_hydr%th_aroot(j), & + ccohort_hydr%psi_aroot(j), site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, 4, ccohort_hydr%psi_aroot(j), & + ccohort_hydr%flc_aroot(j), site_hydr, bc_in) + end do + call flc_gs_from_psi(currentCohort, ccohort_hydr%psi_ag(1)) + ccohort_hydr%qtop_dt = (currentCohort%n*ccohort_hydr%qtop_dt + & + nextCohort%n*ncohort_hydr%qtop_dt)/newn + ccohort_hydr%dqtopdth_dthdt = (currentCohort%n*ccohort_hydr%dqtopdth_dthdt + & + nextCohort%n*ncohort_hydr%dqtopdth_dthdt)/newn + ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & + nextCohort%n*ncohort_hydr%sapflow)/newn + ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & + nextCohort%n*ncohort_hydr%rootuptake)/newn + ccohort_hydr%rootuptake01 = (currentCohort%n*ccohort_hydr%rootuptake01 + & + nextCohort%n*ncohort_hydr%rootuptake01)/newn + ccohort_hydr%rootuptake02 = (currentCohort%n*ccohort_hydr%rootuptake02 + & + nextCohort%n*ncohort_hydr%rootuptake02)/newn + ccohort_hydr%rootuptake03 = (currentCohort%n*ccohort_hydr%rootuptake03 + & + nextCohort%n*ncohort_hydr%rootuptake03)/newn + ccohort_hydr%rootuptake04 = (currentCohort%n*ccohort_hydr%rootuptake04 + & + nextCohort%n*ncohort_hydr%rootuptake04)/newn + ccohort_hydr%rootuptake05 = (currentCohort%n*ccohort_hydr%rootuptake05 + & + nextCohort%n*ncohort_hydr%rootuptake05)/newn + ccohort_hydr%rootuptake06 = (currentCohort%n*ccohort_hydr%rootuptake06 + & + nextCohort%n*ncohort_hydr%rootuptake06)/newn + ccohort_hydr%rootuptake07 = (currentCohort%n*ccohort_hydr%rootuptake07 + & + nextCohort%n*ncohort_hydr%rootuptake07)/newn + ccohort_hydr%rootuptake08 = (currentCohort%n*ccohort_hydr%rootuptake08 + & + nextCohort%n*ncohort_hydr%rootuptake08)/newn + ccohort_hydr%rootuptake09 = (currentCohort%n*ccohort_hydr%rootuptake09 + & + nextCohort%n*ncohort_hydr%rootuptake09)/newn + ccohort_hydr%rootuptake10 = (currentCohort%n*ccohort_hydr%rootuptake10 + & + nextCohort%n*ncohort_hydr%rootuptake10)/newn + + ccohort_hydr%lwp_mem(:) = ccohort_hydr%psi_ag(1) + ccohort_hydr%lwp_stable = ccohort_hydr%psi_ag(1) + ccohort_hydr%lwp_is_unstable = .false. + ccohort_hydr%flc_min_ag(:) = (currentCohort%n*ccohort_hydr%flc_min_ag(:) + & + nextCohort%n*ncohort_hydr%flc_min_ag(:))/newn + ccohort_hydr%flc_min_troot(:) = (currentCohort%n*ccohort_hydr%flc_min_troot(:) + & + nextCohort%n*ncohort_hydr%flc_min_troot(:))/newn + ccohort_hydr%flc_min_aroot(:) = (currentCohort%n*ccohort_hydr%flc_min_aroot(:) + & + nextCohort%n*ncohort_hydr%flc_min_aroot(:))/newn + + ! need to be migrated to parmeter file (BOC 07/24/2018) + ccohort_hydr%refill_thresh = -0.01_r8 + ccohort_hydr%refill_days = 3.0_r8 + + ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & + nextCohort%n*ncohort_hydr%errh2o)/newn + ccohort_hydr%errh2o_growturn_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_ag(:) + & + nextCohort%n*ncohort_hydr%errh2o_growturn_ag(:))/newn + ccohort_hydr%errh2o_pheno_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_ag(:) + & + nextCohort%n*ncohort_hydr%errh2o_pheno_ag(:))/newn + ccohort_hydr%errh2o_growturn_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot(:) + & + nextCohort%n*ncohort_hydr%errh2o_growturn_troot(:))/newn + ccohort_hydr%errh2o_pheno_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot(:) + & + nextCohort%n*ncohort_hydr%errh2o_pheno_troot(:))/newn + ccohort_hydr%errh2o_growturn_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot(:) + & + nextCohort%n*ncohort_hydr%errh2o_growturn_aroot(:))/newn + ccohort_hydr%errh2o_pheno_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot(:) + & + nextCohort%n*ncohort_hydr%errh2o_pheno_aroot(:))/newn + + !ccohort_hydr%th_aroot_prev(:) + !ccohort_hydr%th_aroot_prev_uncorr(:) + + ccohort_hydr%is_newly_recruited = .false. + + end subroutine FuseCohortHydraulics ! ===================================================================================== - ! Initialization Routines - ! ===================================================================================== - + ! Initialization Routines + ! ===================================================================================== + subroutine InitHydrCohort(currentSite,currentCohort) ! Arguments @@ -1262,7 +1316,7 @@ subroutine InitHydrCohort(currentSite,currentCohort) call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevsoi_hyd) ccohort_hydr%is_newly_recruited = .false. - + end subroutine InitHydrCohort ! ===================================================================================== @@ -1273,7 +1327,7 @@ subroutine DeallocateHydrCohort(currentCohort) type(ed_cohort_hydr_type), pointer :: ccohort_hydr if ( hlm_use_planthydro.eq.ifalse ) return - + ccohort_hydr => currentCohort%co_hydr call ccohort_hydr%DeAllocateHydrCohortArrays() deallocate(ccohort_hydr) @@ -1285,381 +1339,381 @@ end subroutine DeallocateHydrCohort subroutine InitHydrSites(sites,bc_in,numpft) - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) - integer,intent(in) :: numpft - - ! Locals - integer :: nsites - integer :: s - type(ed_site_hydr_type),pointer :: csite_hydr - - - if ( hlm_use_planthydro.eq.ifalse ) return - - ! Initialize any derived hydraulics parameters - call InitHydraulicsDerived(numpft) - - nsites = ubound(sites,1) - do s=1,nsites - allocate(csite_hydr) - sites(s)%si_hydr => csite_hydr - if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then - write(fates_log(),*) 'The host land model has defined soil with' - write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' - write(fates_log(),*) 'Fates-hydro temporary array spaces with size' - write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' - write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil - call sites(s)%si_hydr%InitHydrSite() - end do + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) + integer,intent(in) :: numpft + + ! Locals + integer :: nsites + integer :: s + type(ed_site_hydr_type),pointer :: csite_hydr + + + if ( hlm_use_planthydro.eq.ifalse ) return - end subroutine InitHydrSites + ! Initialize any derived hydraulics parameters + call InitHydraulicsDerived(numpft) + + nsites = ubound(sites,1) + do s=1,nsites + allocate(csite_hydr) + sites(s)%si_hydr => csite_hydr + if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then + write(fates_log(),*) 'The host land model has defined soil with' + write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' + write(fates_log(),*) 'Fates-hydro temporary array spaces with size' + write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' + write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil + call sites(s)%si_hydr%InitHydrSite() + end do + + end subroutine InitHydrSites - ! =================================================================================== + ! =================================================================================== subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) - - - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) - - ! Local - type(ed_site_hydr_type), pointer :: site_hydr - real(r8) :: smp ! matric potential temp - real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) - integer :: s - integer :: j - integer :: nsites - integer :: nlevsoil ! Number of soil layers - integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers - - nsites = ubound(sites,1) - - do s = 1,nsites - site_hydr => sites(s)%si_hydr - - nlevsoil = bc_in(s)%nlevsoil - nlevsoil_hyd = site_hydr%nlevsoi_hyd - - if ( nlevsoil_hyd == 1) then - - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(nlevsoil), & - bc_in(s)%h2o_liq_sisl(nlevsoil)/(bc_in(s)%dz_sisl(nlevsoil)*denh2o)) - - site_hydr%h2osoi_liqvol_shell(nlevsoil_hyd,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(nlevsoil_hyd) = bc_in(s)%h2o_liq_sisl(nlevsoil) - else - do j = 1,nlevsoil_hyd - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) - - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - end do - end if - - do j = 1, nlevsoil_hyd - ! Calculate the matric potential on the innner shell (this is used to initialize - ! xylem and root pressures in new cohorts) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), smp) - - site_hydr%psisoi_liq_innershell(j) = smp - - end do - site_hydr%l_aroot_layer(1:site_hydr%nlevsoi_hyd) = 0.0_r8 - - end do - - ! - !! call UpdateH2OVeg(nsites,sites,bc_out) - - ! -------------------------------------------------------------------------------- - ! All other ed_Hydr_site_type variables are initialized elsewhere: - ! - ! init_patch() -> updateSizeDepRhizHydProps -> shellgeom() - ! this%v_shell - ! this%v_shell_1D - ! this%r_node_shell - ! this%r_out_shell - ! this%r_out_shell_1D - ! this%r_node_shell_1D - ! - ! init_patch() -> updateSizeDepRhizHydProps() - ! this%l_aroot_layer_init - ! this%l_aroot_1D - ! this%kmax_upper_shell - ! this%kmax_bound_shell - ! this%kmax_lower_shell - ! this%kmax_upper_shell_1D - ! this%kmax_bound_shell_1D - ! this%kmax_lower_shell_1D - ! - ! hydraulics_bc() - ! this%supsub_flag - ! this%errh2o_hyd = ! hydraulics_bc - ! this%dwat_veg = ! hydraulics_bc - ! - ! ed_update_site() -> update_h2oveg() - ! this%h2oveg - ! -------------------------------------------------------------------------------- - - return + + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) + + ! Local + type(ed_site_hydr_type), pointer :: site_hydr + real(r8) :: smp ! matric potential temp + real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) + integer :: s + integer :: j + integer :: nsites + integer :: nlevsoil ! Number of soil layers + integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers + + nsites = ubound(sites,1) + + do s = 1,nsites + site_hydr => sites(s)%si_hydr + + nlevsoil = bc_in(s)%nlevsoil + nlevsoil_hyd = site_hydr%nlevsoi_hyd + + if ( nlevsoil_hyd == 1) then + + h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(nlevsoil), & + bc_in(s)%h2o_liq_sisl(nlevsoil)/(bc_in(s)%dz_sisl(nlevsoil)*denh2o)) + + site_hydr%h2osoi_liqvol_shell(nlevsoil_hyd,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(nlevsoil_hyd) = bc_in(s)%h2o_liq_sisl(nlevsoil) + else + do j = 1,nlevsoil_hyd + h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & + bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + + site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) + end do + end if + + do j = 1, nlevsoil_hyd + ! Calculate the matric potential on the innner shell (this is used to initialize + ! xylem and root pressures in new cohorts) + call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & + bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(j), smp) + + site_hydr%psisoi_liq_innershell(j) = smp + + end do + site_hydr%l_aroot_layer(1:site_hydr%nlevsoi_hyd) = 0.0_r8 + + end do + + ! + !! call UpdateH2OVeg(nsites,sites,bc_out) + + ! -------------------------------------------------------------------------------- + ! All other ed_Hydr_site_type variables are initialized elsewhere: + ! + ! init_patch() -> updateSizeDepRhizHydProps -> shellgeom() + ! this%v_shell + ! this%v_shell_1D + ! this%r_node_shell + ! this%r_out_shell + ! this%r_out_shell_1D + ! this%r_node_shell_1D + ! + ! init_patch() -> updateSizeDepRhizHydProps() + ! this%l_aroot_layer_init + ! this%l_aroot_1D + ! this%kmax_upper_shell + ! this%kmax_bound_shell + ! this%kmax_lower_shell + ! this%kmax_upper_shell_1D + ! this%kmax_bound_shell_1D + ! this%kmax_lower_shell_1D + ! + ! hydraulics_bc() + ! this%supsub_flag + ! this%errh2o_hyd = ! hydraulics_bc + ! this%dwat_veg = ! hydraulics_bc + ! + ! ed_update_site() -> update_h2oveg() + ! this%h2oveg + ! -------------------------------------------------------------------------------- + + return end subroutine HydrSiteColdStart ! ===================================================================================== subroutine UpdateH2OVeg(nsites,sites,bc_out) - ! ---------------------------------------------------------------------------------- - ! This subroutine is called following dynamics. After growth has been updated - ! there needs to be a re-assesment of the how much liquid water is bound in the - ! plants. This value is necessary for water balancing in the HLM. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod, only : AREA - - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s - real(r8) :: balive_patch - integer :: nstep !number of time steps - - !for debug only - nstep = get_nstep() - - do s = 1,nsites - bc_out(s)%plant_stored_h2o_si = 0.0_r8 - end do - - if( hlm_use_planthydro.eq.ifalse ) return - - do s = 1,nsites - - csite_hydr => sites(s)%si_hydr - csite_hydr%h2oveg = 0.0_r8 - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - !only account for the water for not newly recruit for mass balance - if(.not.ccohort_hydr%is_newly_recruited) then + ! ---------------------------------------------------------------------------------- + ! This subroutine is called following dynamics. After growth has been updated + ! there needs to be a re-assesment of the how much liquid water is bound in the + ! plants. This value is necessary for water balancing in the HLM. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod, only : AREA + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s + real(r8) :: balive_patch + integer :: nstep !number of time steps + + !for debug only + nstep = get_nstep() + + do s = 1,nsites + bc_out(s)%plant_stored_h2o_si = 0.0_r8 + end do + + if( hlm_use_planthydro.eq.ifalse ) return + + do s = 1,nsites + + csite_hydr => sites(s)%si_hydr + csite_hydr%h2oveg = 0.0_r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + !only account for the water for not newly recruit for mass balance + if(.not.ccohort_hydr%is_newly_recruited) then csite_hydr%h2oveg = csite_hydr%h2oveg + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - endif - - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop - - csite_hydr%h2oveg = csite_hydr%h2oveg / AREA - - ! Note that h2oveg_dead is incremented wherever we have litter fluxes - ! and it will be reduced via an evaporation term - ! growturn_err is a term to accomodate error in growth or turnover. need to be improved for future(CX) - bc_out(s)%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & - csite_hydr%h2oveg_growturn_err - & - csite_hydr%h2oveg_pheno_err-& - csite_hydr%h2oveg_hydro_err - - end do - - + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + endif + + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop + + csite_hydr%h2oveg = csite_hydr%h2oveg / AREA + + ! Note that h2oveg_dead is incremented wherever we have litter fluxes + ! and it will be reduced via an evaporation term + ! growturn_err is a term to accomodate error in growth or turnover. need to be improved for future(CX) + bc_out(s)%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & + csite_hydr%h2oveg_growturn_err - & + csite_hydr%h2oveg_pheno_err-& + csite_hydr%h2oveg_hydro_err + + end do + + return end subroutine UpdateH2OVeg - + !===================================================================================== subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - ! ---------------------------------------------------------------------------------- - ! This subroutine is called to caluate the water requirement for newly recruited cohorts - ! The water update is allocated proportionally to the root biomass, which could be updated - ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). - ! After the root water uptake, is_newly_recruited flag is set to false. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod, only : AREA - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - real(r8), intent(in) :: dtime !time (seconds) - logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts - - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s, j, ft - integer :: nstep !number of time steps - real(r8) :: roota !root distriubiton parameter a - real(r8) :: rootb !root distriubiton parameter b - real(r8) :: rootfr !fraction of root in different soil layer - real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) - real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) - real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) - real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) - - recruitflag = .false. - do s = 1,nsites - csite_hydr => sites(s)%si_hydr - csite_hydr%recruit_w_uptake = 0.0_r8 - currentPatch => sites(s)%oldest_patch - recruitw_total = 0.0_r8 - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - ft = currentCohort%pft - !----------------------------------------------------------- - ! recruitment water uptake - if(ccohort_hydr%is_newly_recruited) then - recruitflag = .true. - roota = EDPftvarcon_inst%roota_par(ft) + ! ---------------------------------------------------------------------------------- + ! This subroutine is called to caluate the water requirement for newly recruited cohorts + ! The water update is allocated proportionally to the root biomass, which could be updated + ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). + ! After the root water uptake, is_newly_recruited flag is set to false. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod, only : AREA + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + real(r8), intent(in) :: dtime !time (seconds) + logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s, j, ft + integer :: nstep !number of time steps + real(r8) :: roota !root distriubiton parameter a + real(r8) :: rootb !root distriubiton parameter b + real(r8) :: rootfr !fraction of root in different soil layer + real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) + real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) + real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) + real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) + + recruitflag = .false. + do s = 1,nsites + csite_hydr => sites(s)%si_hydr + csite_hydr%recruit_w_uptake = 0.0_r8 + currentPatch => sites(s)%oldest_patch + recruitw_total = 0.0_r8 + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + ft = currentCohort%pft + !----------------------------------------------------------- + ! recruitment water uptake + if(ccohort_hydr%is_newly_recruited) then + recruitflag = .true. + roota = EDPftvarcon_inst%roota_par(ft) rootb = EDPftvarcon_inst%rootb_par(ft) - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n/AREA/dtime - recruitw_total = recruitw_total + recruitw + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n/AREA/dtime + recruitw_total = recruitw_total + recruitw if( csite_hydr%nlevsoi_hyd == 1) then - csite_hydr%recruit_w_uptake(1) = csite_hydr%recruit_w_uptake(1)+ & - recruitw + csite_hydr%recruit_w_uptake(1) = csite_hydr%recruit_w_uptake(1)+ & + recruitw else - do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1)) - end if - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - recruitw*rootfr - end do + do j=1,csite_hydr%nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1)) + end if + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + recruitw*rootfr + end do end if - ccohort_hydr%is_newly_recruited = .false. - endif - currentCohort=>currentCohort%shorter - end do !cohort loop + ccohort_hydr%is_newly_recruited = .false. + endif + currentCohort=>currentCohort%shorter + end do !cohort loop currentPatch => currentPatch%younger - end do !patch - !balance check - sumrw_uptake = sum(csite_hydr%recruit_w_uptake) - err = recruitw_total - sumrw_uptake - if(abs(err)>1.0e-10_r8)then - do j=1,csite_hydr%nlevsoi_hyd - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake - enddo - endif - end do ! site loop - - end subroutine RecruitWUptake - + end do !patch + !balance check + sumrw_uptake = sum(csite_hydr%recruit_w_uptake) + err = recruitw_total - sumrw_uptake + if(abs(err)>1.0e-10_r8)then + do j=1,csite_hydr%nlevsoi_hyd + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake + enddo + endif + end do ! site loop + + end subroutine RecruitWUptake + !===================================================================================== subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) - ! --------------------------------------------------------------------------- - ! This subroutine constrains the number of plants so that there is enought water - ! for newly recruited individuals from the soil - ! --------------------------------------------------------------------------- - use EDTypesMod, only : AREA - - ! Arguments - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - type(bc_in_type) , intent(in) :: bc_in - - ! Locals - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - real(r8) :: tmp1 - real(r8) :: watres_local !minum water content - real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3) - real(r8) :: total_water_min !total minimum water in rhizosphere at a specific layer (m^3) - real(r8) :: roota !root distriubiton parameter a - real(r8) :: rootb !root distriubiton parameter b - real(r8) :: rootfr !fraction of root in different soil layer - real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/individual) - real(r8) :: n, nmin !number of individuals in cohorts - integer :: s, j, ft - - roota = EDPftvarcon_inst%roota_par(ccohort%pft) - rootb = EDPftvarcon_inst%rootb_par(ccohort%pft) - - csite_hydr => csite%si_hydr - ccohort_hydr =>ccohort%co_hydr - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o - - do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - cohort_recruit_water_layer(j) = recruitw*rootfr - end do - - do j=1,csite_hydr%nlevsoi_hyd - select case (iswc) - case (van_genuchten) - write(fates_log(),*) & - 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in%smpmin_si*denh2o*grav*1.e-9_r8, & - (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(j), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in%watsat_sisl(j), & - watres_local) - - - case default - end select - total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) * & - csite_hydr%l_aroot_layer(j)/& - bc_in %dz_sisl(j) - total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) * & - csite_hydr%l_aroot_layer(j)/& - bc_in %dz_sisl(j) - !assumes that only 50% is available for recruit water.... - recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) - - end do - - nmin = 1.0e+36 - do j=1,csite_hydr%nlevsoi_hyd + ! --------------------------------------------------------------------------- + ! This subroutine constrains the number of plants so that there is enought water + ! for newly recruited individuals from the soil + ! --------------------------------------------------------------------------- + use EDTypesMod, only : AREA + + ! Arguments + type(ed_site_type), intent(inout), target :: csite + type(ed_cohort_type) , intent(inout), target :: ccohort + type(bc_in_type) , intent(in) :: bc_in + + ! Locals + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + real(r8) :: tmp1 + real(r8) :: watres_local !minum water content + real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3) + real(r8) :: total_water_min !total minimum water in rhizosphere at a specific layer (m^3) + real(r8) :: roota !root distriubiton parameter a + real(r8) :: rootb !root distriubiton parameter b + real(r8) :: rootfr !fraction of root in different soil layer + real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/individual) + real(r8) :: n, nmin !number of individuals in cohorts + integer :: s, j, ft + + roota = EDPftvarcon_inst%roota_par(ccohort%pft) + rootb = EDPftvarcon_inst%rootb_par(ccohort%pft) + + csite_hydr => csite%si_hydr + ccohort_hydr =>ccohort%co_hydr + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o + + do j=1,csite_hydr%nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + cohort_recruit_water_layer(j) = recruitw*rootfr + end do + + do j=1,csite_hydr%nlevsoi_hyd + select case (iswc) + case (van_genuchten) + write(fates_log(),*) & + 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case (campbell) + call swcCampbell_satfrac_from_psi(bc_in%smpmin_si*denh2o*grav_earth*1.e-9_r8, & + (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(j), & + tmp1) + call swcCampbell_th_from_satfrac(tmp1, & + bc_in%watsat_sisl(j), & + watres_local) + + + case default + end select + total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) * & + csite_hydr%l_aroot_layer(j)/& + bc_in %dz_sisl(j) + total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) * & + csite_hydr%l_aroot_layer(j)/& + bc_in %dz_sisl(j) + !assumes that only 50% is available for recruit water.... + recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) + + end do + + nmin = 1.0e+36 + do j=1,csite_hydr%nlevsoi_hyd if(cohort_recruit_water_layer(j)>0.0_r8) then n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) nmin = min(n, nmin) endif - end do - ccohort%n = min (ccohort%n, nmin) + end do + ccohort%n = min (ccohort%n, nmin) end subroutine ConstrainRecruitNumber @@ -1673,17 +1727,17 @@ subroutine SavePreviousRhizVolumes(currentSite, bc_in) type(bc_in_type) , intent(in) :: bc_in type(ed_site_hydr_type), pointer :: csite_hydr integer :: nlevsoi_hyd - + csite_hydr => currentSite%si_hydr nlevsoi_hyd = csite_hydr%nlevsoi_hyd - + csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) - + return end subroutine SavePreviousRhizVolumes - + ! ====================================================================================== subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) @@ -1696,7 +1750,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! ! !USES: use EDTypesMod , only : AREA - + ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -1708,16 +1762,16 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) type(ed_cohort_type) , pointer :: cCohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] + ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the - ! innermost shell radius is less than the assumed - ! absorbing root radius rs1 - ! 1.e-5_r8 from Rudinger et al 1994 + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 integer :: nlevsoi_hyd !----------------------------------------------------------------------- - + csite_hydr => currentSite%si_hydr nlevsoi_hyd = csite_hydr%nlevsoi_hyd @@ -1735,43 +1789,46 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) enddo !patch csite_hydr%l_aroot_1D = sum( csite_hydr%l_aroot_layer(:)) - + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) do j = 1,nlevsoi_hyd ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, bc_in%dz_sisl(j), & - csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) + csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) end if !has l_aroot_layer changed? enddo call shellGeom( csite_hydr%l_aroot_1D, csite_hydr%rs1(1), AREA, sum(bc_in%dz_sisl(1:nlevsoi_hyd)), & - csite_hydr%r_out_shell_1D(:), csite_hydr%r_node_shell_1D(:), csite_hydr%v_shell_1D(:)) - - !update the conductitivity for first soil shell is done at subroutine UpdateWaterDepTreeHydrCond + csite_hydr%r_out_shell_1D(:), csite_hydr%r_node_shell_1D(:), csite_hydr%v_shell_1D(:)) + + !update the conductitivity for first soil shell is done at subroutine KmaxInnerShell !which is dependant on whether it is water uptake or loss for every 30 minutes - + do j = 1,csite_hydr%nlevsoi_hyd - - hksat_s = bc_in%hksat_sisl(j) * 1.e-3_r8 * 1/grav * 1.e6_r8 + + hksat_s = bc_in%hksat_sisl(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa ! proceed only if the total absorbing root length (site-level) has changed in this layer if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then do k = 2,nshell - csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - csite_hydr%kmax_bound_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_node_shell(j,k-1))*hksat_s - csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s - if(j == 1) then - csite_hydr%kmax_upper_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_out_shell_1D(k-1))*hksat_s - csite_hydr%kmax_bound_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_node_shell_1D(k-1))*hksat_s - csite_hydr%kmax_lower_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_out_shell_1D( k)/csite_hydr%r_node_shell_1D(k ))*hksat_s - end if + csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s + + csite_hydr%kmax_bound_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_node_shell(j,k-1))*hksat_s + + csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + if(j == 1) then + csite_hydr%kmax_upper_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & + log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_out_shell_1D(k-1))*hksat_s + csite_hydr%kmax_bound_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & + log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_node_shell_1D(k-1))*hksat_s + csite_hydr%kmax_lower_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & + log(csite_hydr%r_out_shell_1D( k)/csite_hydr%r_node_shell_1D(k ))*hksat_s + end if enddo ! loop over rhizosphere shells end if !has l_aroot_layer changed? enddo ! loop over soil layers @@ -1779,7 +1836,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) return end subroutine UpdateSizeDepRhizVolLenCon - + ! ===================================================================================== @@ -1794,7 +1851,7 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) ! !USES: use EDTypesMod , only : AREA - + ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -1802,18 +1859,18 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) ! Save current volumes, lenghts and nodes to an "initial" ! used to calculate effects in states later on. - + call SavePreviousRhizVolumes(currentSite, bc_in) ! Update the properties of the vegetation-soil hydraulic environment ! these are independent on the water state - + call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) return end subroutine updateSizeDepRhizHydProps - + ! ================================================================================= subroutine updateSizeDepRhizHydStates(currentSite, bc_in) @@ -1849,7 +1906,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) logical :: found ! flag in search loop type(ed_site_hydr_type), pointer :: csite_hydr !----------------------------------------------------------------------- - + s_shell_init(:,:) = 0._r8 psi_shell_init(:,:) = 0._r8 psi_shell_interp(:,:) = 0._r8 @@ -1858,235 +1915,235 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) csite_hydr => currentSite%si_hydr if(.false.) then - ! calculate initial s, psi by layer and shell - do j = 1, csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - select case (iswc) - case (van_genuchten) - do k = 1,nshell - s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) - write(fates_log(),*) 'VG is not available yet' + ! calculate initial s, psi by layer and shell + do j = 1, csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + select case (iswc) + case (van_genuchten) + do k = 1,nshell + s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & + (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) + write(fates_log(),*) 'VG is not available yet' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_psi_from_satfrac(s_shell_init(j,k),alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),psi_shell_init(j,k)) + end do + case (campbell) + do k = 1,nshell + s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & + (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) + call swcCampbell_psi_from_satfrac( s_shell_init(j,k), & + bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(j),psi_shell_init(j,k)) + end do + case default + write(fates_log(),*) 'Somehow you picked a PT function that DNE' call endrun(msg=errMsg(sourcefile, __LINE__)) -! call swcVG_psi_from_satfrac(s_shell_init(j,k),alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),psi_shell_init(j,k)) - end do - case (campbell) - do k = 1,nshell - s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) - call swcCampbell_psi_from_satfrac( s_shell_init(j,k), & - bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(j),psi_shell_init(j,k)) - end do - case default - write(fates_log(),*) 'Somehow you picked a PT function that DNE' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if !has l_aroot_coh changed? - enddo - - ! interpolate initial psi values by layer and shell - ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) - do j = 1,csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + end select + end if !has l_aroot_coh changed? + enddo + + ! interpolate initial psi values by layer and shell + ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) + do j = 1,csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + + ! fine root length increased, thus shrinking the rhizosphere size + if(csite_hydr%r_node_shell(j,nshell) < csite_hydr%r_node_shell_init(j,nshell)) then + r_delta = csite_hydr%r_node_shell(j,1) - csite_hydr%r_node_shell_init(j,1) + !dpsidr = (psi_shell_init(j,2) - psi_shell_init(j,1)) / & + ! (csite_hydr%r_node_shell_init(j,2) - csite_hydr%r_node_shell_init(j,1)) + + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! HACK for special case of nshell = 1 -- compiler throws error because of index 2 in above line, + ! even though at run-time the code should skip over this section: MUST FIX + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + dpsidr = (psi_shell_init(j,1) - psi_shell_init(j,1)) / & + (csite_hydr%r_node_shell_init(j,1) - csite_hydr%r_node_shell_init(j,1)) + psi_shell_interp(j,1) = dpsidr * r_delta + do k = 2,nshell + r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) + dpsidr = (psi_shell_init(j,k) - psi_shell_init(j,k-1)) / & + (csite_hydr%r_node_shell_init(j,k) - csite_hydr%r_node_shell_init(j,k-1)) + psi_shell_interp(j,k) = dpsidr * r_delta + enddo + else + ! fine root length decreased, thus increasing the rhizosphere size + do k = 1,(nshell-1) + r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) + dpsidr = (psi_shell_init(j,k+1) - psi_shell_init(j,k)) / & + (csite_hydr%r_node_shell_init(j,k+1) - csite_hydr%r_node_shell_init(j,k)) + psi_shell_interp(j,k) = dpsidr * r_delta + enddo + r_delta = csite_hydr%r_node_shell(j,nshell) - csite_hydr%r_node_shell_init(j,nshell) + !dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell-1)) / & + ! (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell-1)) + + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! HACK for special case of nshell = 1 -- compiler throws error because of index nshell-1 in + ! above line, even though at run-time the code should skip over this section: MUST FIX + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell)) / & + (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell)) - ! fine root length increased, thus shrinking the rhizosphere size - if(csite_hydr%r_node_shell(j,nshell) < csite_hydr%r_node_shell_init(j,nshell)) then - r_delta = csite_hydr%r_node_shell(j,1) - csite_hydr%r_node_shell_init(j,1) - !dpsidr = (psi_shell_init(j,2) - psi_shell_init(j,1)) / & - ! (csite_hydr%r_node_shell_init(j,2) - csite_hydr%r_node_shell_init(j,1)) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index 2 in above line, - ! even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - dpsidr = (psi_shell_init(j,1) - psi_shell_init(j,1)) / & - (csite_hydr%r_node_shell_init(j,1) - csite_hydr%r_node_shell_init(j,1)) - psi_shell_interp(j,1) = dpsidr * r_delta - do k = 2,nshell - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k) - psi_shell_init(j,k-1)) / & - (csite_hydr%r_node_shell_init(j,k) - csite_hydr%r_node_shell_init(j,k-1)) - psi_shell_interp(j,k) = dpsidr * r_delta - enddo - else - ! fine root length decreased, thus increasing the rhizosphere size - do k = 1,(nshell-1) - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k+1) - psi_shell_init(j,k)) / & - (csite_hydr%r_node_shell_init(j,k+1) - csite_hydr%r_node_shell_init(j,k)) psi_shell_interp(j,k) = dpsidr * r_delta - enddo - r_delta = csite_hydr%r_node_shell(j,nshell) - csite_hydr%r_node_shell_init(j,nshell) - !dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell-1)) / & - ! (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell-1)) + end if + end if !has l_aroot_coh changed? + enddo - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index nshell-1 in - ! above line, even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + ! 1st guess at new s based on interpolated psi + do j = 1,csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + select case (iswc) + case (van_genuchten) + do k = 1,nshell + write(fates_log(),*) 'VG is not available yet' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_satfrac_from_psi(psi_shell_interp(j,k), & + ! alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),s_shell_interp(j,k)) + enddo + case (campbell) + do k = 1,nshell + call swcCampbell_satfrac_from_psi(psi_shell_interp(j,k), & + (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(j), & + s_shell_interp(j,k)) + end do + case default + write(fates_log(),*) 'Somehow you picked a PT function that DNE' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell)) / & - (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell)) + end if !has l_aroot_coh changed? + enddo - psi_shell_interp(j,k) = dpsidr * r_delta - end if - end if !has l_aroot_coh changed? - enddo - - ! 1st guess at new s based on interpolated psi - do j = 1,csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - select case (iswc) - case (van_genuchten) + ! accumlate water across shells for each layer (initial and interpolated) + do j = 1,csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + w_layer_init(j) = 0._r8 + w_layer_interp(j) = 0._r8 + v_rhiz(j) = 0._r8 do k = 1,nshell - write(fates_log(),*) 'VG is not available yet' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call swcVG_satfrac_from_psi(psi_shell_interp(j,k), & - ! alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),s_shell_interp(j,k)) + w_layer_init(j) = w_layer_init(j) + denh2o/bc_in%dz_sisl(j) * & + ( csite_hydr%l_aroot_layer_init(j) * & + csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) + w_layer_interp(j) = w_layer_interp(j) + denh2o/bc_in%dz_sisl(j) * & + ( csite_hydr%l_aroot_layer(j)*csite_hydr%v_shell(j,k) * & + (s_shell_interp(j,k)*(bc_in%watsat_sisl(j)-bc_in%watres_sisl(j))+bc_in%watres_sisl(j)) ) + v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) enddo - case (campbell) + end if !has l_aroot_coh changed? + enddo + + ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change + ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. + do j = 1,csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * & + denh2o*csite_hydr%l_aroot_layer(j)/bc_in%dz_sisl(j) ) - bc_in%watres_sisl(j)) / & + (bc_in%watsat_sisl(j)-bc_in%watres_sisl(j)) + end if !has l_aroot_coh changed? + enddo + + ! update h2osoi_liqvol_shell and h2osoi_liq_shell + do j = 1,csite_hydr%nlevsoi_hyd + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + w_layer_new(j) = 0._r8 do k = 1,nshell - call swcCampbell_satfrac_from_psi(psi_shell_interp(j,k), & - (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(j), & - s_shell_interp(j,k)) - end do - case default - write(fates_log(),*) 'Somehow you picked a PT function that DNE' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) + csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & + ( bc_in%watsat_sisl(j)-bc_in%watres_sisl(j) ) + bc_in%watres_sisl(j) + w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & + csite_hydr%v_shell(j,k) * denh2o + w_layer_new(j) = w_layer_new(j) + w_shell_new + enddo + h2osoi_liq_col_new(j) = w_layer_new(j)/( v_rhiz(j)/bc_in%dz_sisl(j) ) + end if !has l_aroot_coh changed? + enddo - end if !has l_aroot_coh changed? - enddo - - ! accumlate water across shells for each layer (initial and interpolated) - do j = 1,csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_init(j) = 0._r8 - w_layer_interp(j) = 0._r8 - v_rhiz(j) = 0._r8 - do k = 1,nshell - w_layer_init(j) = w_layer_init(j) + denh2o/bc_in%dz_sisl(j) * & - ( csite_hydr%l_aroot_layer_init(j) * & - csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) - w_layer_interp(j) = w_layer_interp(j) + denh2o/bc_in%dz_sisl(j) * & - ( csite_hydr%l_aroot_layer(j)*csite_hydr%v_shell(j,k) * & - (s_shell_interp(j,k)*(bc_in%watsat_sisl(j)-bc_in%watres_sisl(j))+bc_in%watres_sisl(j)) ) - v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) - enddo - end if !has l_aroot_coh changed? - enddo - - ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change - ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. - do j = 1,csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * & - denh2o*csite_hydr%l_aroot_layer(j)/bc_in%dz_sisl(j) ) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j)-bc_in%watres_sisl(j)) - end if !has l_aroot_coh changed? - enddo - - ! update h2osoi_liqvol_shell and h2osoi_liq_shell - do j = 1,csite_hydr%nlevsoi_hyd - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_new(j) = 0._r8 - do k = 1,nshell - s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) - csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & - ( bc_in%watsat_sisl(j)-bc_in%watres_sisl(j) ) + bc_in%watres_sisl(j) - w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & - csite_hydr%v_shell(j,k) * denh2o - w_layer_new(j) = w_layer_new(j) + w_shell_new - enddo - h2osoi_liq_col_new(j) = w_layer_new(j)/( v_rhiz(j)/bc_in%dz_sisl(j) ) - end if !has l_aroot_coh changed? - enddo - - ! balance check - do j = 1,csite_hydr%nlevsoi_hyd - ! BOC: PLEASE CHECK UNITS ON h2o_liq_sisl(j) (RGK) - errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j) - if (abs(errh2o(j)) > 1.e-4_r8) then - found = .true. - indexj = j - if( found ) then - write(fates_log(),*)'WARNING: water balance error ',& - ' local indexj= ',indexj,& - ' errh2o= ',errh2o(indexj) + ! balance check + do j = 1,csite_hydr%nlevsoi_hyd + ! BOC: PLEASE CHECK UNITS ON h2o_liq_sisl(j) (RGK) + errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j) + if (abs(errh2o(j)) > 1.e-4_r8) then + found = .true. + indexj = j + if( found ) then + write(fates_log(),*)'WARNING: water balance error ',& + ' local indexj= ',indexj,& + ' errh2o= ',errh2o(indexj) + end if end if - end if - enddo - end if !nshell > 1 - + enddo + end if !nshell > 1 + end subroutine updateSizeDepRhizHydStates ! ==================================================================================== subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - ! Locals - integer :: s - integer :: ifp - real(r8) :: balive_patch - type(ed_patch_type),pointer :: cpatch - type(ed_cohort_type),pointer :: ccohort - - do s = 1,nsites - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp=ifp+1 - - balive_patch = 0._r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - balive_patch = balive_patch + & - (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & - cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & - cCohort%prt%GetState(leaf_organ, all_carbon_elements))* ccohort%n - ccohort => ccohort%shorter - enddo !cohort - - bc_out(s)%btran_pa(ifp) = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & - ccohort%co_hydr%btran(1) * & - (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & - cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & - cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & - ccohort%n / balive_patch - ccohort => ccohort%shorter - enddo !cohort - cpatch => cpatch%younger - enddo !end patch loop - end do - return - end subroutine BTranForHLMDiagnosticsFromCohortHydr - - ! ========================================================================== + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) - subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) - ! - ! Created by Brad Christoffersen, Jan 2016 - ! - ! !DESCRIPTION: - ! Parses out mean vertical water fluxes resulting from infiltration, + ! Locals + integer :: s + integer :: ifp + real(r8) :: balive_patch + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + balive_patch = 0._r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + balive_patch = balive_patch + & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements))* ccohort%n + ccohort => ccohort%shorter + enddo !cohort + + bc_out(s)%btran_pa(ifp) = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & + ccohort%co_hydr%btran(1) * & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & + ccohort%n / balive_patch + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !end patch loop + end do + return + end subroutine BTranForHLMDiagnosticsFromCohortHydr + + ! ========================================================================== + + subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) + ! + ! Created by Brad Christoffersen, Jan 2016 + ! + ! !DESCRIPTION: + ! Parses out mean vertical water fluxes resulting from infiltration, ! drainage, and vertical water movement (dwat_kgm2) over radially stratified ! rhizosphere shells. ! @@ -2145,7 +2202,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) do j = 1,csite_hydr%nlevsoi_hyd cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) & / bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) * denh2o/AREA - + if(csite_hydr%nlevsoi_hyd == 1) then dwat_kgm2 = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - cumShellH2O else ! if(csite_hydr%nlevsoi_hyd == bc_in(s)%nlevsoil ) then @@ -2153,14 +2210,14 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) end if dwat_kg = dwat_kgm2 * AREA - + ! order shells in terms of increasing or decreasing volumetric water content ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents if(nshell > 1) then do k = nshell-1,1,-1 do kk = 1,k if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then if (dwat_kg > 0._r8) then !order increasing tmp = ordered(kk) ordered(kk) = ordered(kk+1) @@ -2176,7 +2233,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) enddo enddo end if - + ! fill shells with water up to the water content of the next-wettest shell, ! in order from driest to wettest (dwat_kg > 0) ! ------ OR ------ @@ -2185,9 +2242,9 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) k = 1 do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) / & - bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) + bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) wdiff = thdiff * v_cum * denh2o if(abs(dwat_kg) >= abs(wdiff)) then csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) @@ -2199,27 +2256,27 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) end if k = k + 1 enddo - + if (dwat_kg /= 0._r8) then v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) / bc_in(s)%dz_sisl(j) * & - csite_hydr%l_aroot_layer(j) + csite_hydr%l_aroot_layer(j) thdiff = dwat_kg / v_cum / denh2o do k = nshell, 1, -1 csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff end do end if - + ! m3/m3 * Total volume m3 * kg/m3 = kg h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & csite_hydr%v_shell(j,:) / bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) * denh2o - + enddo - + ! balance check if(csite_hydr%nlevsoi_hyd .ne. 1) then do j = 1,csite_hydr%nlevsoi_hyd errh2o(j) = sum(h2osoi_liq_shell(j,:))/AREA - bc_in(s)%h2o_liq_sisl(j) - + if (abs(errh2o(j)) > 1.e-9_r8) then found = .true. indexj = j @@ -2233,903 +2290,745 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) else errh2o(csite_hydr%nlevsoi_hyd) = sum(h2osoi_liq_shell(csite_hydr%nlevsoi_hyd,:))/AREA - sum( bc_in(s)%h2o_liq_sisl(:) ) end if - + end do return - end subroutine FillDrainRhizShells + end subroutine FillDrainRhizShells - ! ==================================================================================== + ! ==================================================================================== subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) - - ! ---------------------------------------------------------------------------------- - ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics - ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) - ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 - - ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU - ! - ! BOC...for quick implementation avoided JT's abstract interface, - ! but these should be converted to interfaces in the future - ! ---------------------------------------------------------------------------------- - - ! - ! !DESCRIPTION: - !s - ! !USES: - use EDTypesMod , only : AREA - use FatesUtilsMod , only : check_var_real - - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - real(r8),intent(in) :: dtime - - ! - ! !LOCAL VARIABLES: - character(len=*), parameter :: sub = 'clm::Hydraulics_bc' - integer :: iv ! leaf layer - integer :: ifp ! index of FATES patch - integer :: s ! index of FATES site - integer :: j,jj! soil layer - integer :: k ! 1D plant-soil continuum array - integer :: ft ! plant functional type index - integer :: t ! previous timesteps (for lwp stability calculation) - integer :: nstep !number of time steps - - !---------------------------------------------------------------------- - - type (ed_patch_type), pointer :: cpatch - type (ed_cohort_type), pointer :: ccohort - - ! hydraulics global constants - real(r8), parameter :: thresh = 1.e-7_r8 ! threshold for water balance error (warning only) [mm h2o] - real(r8), parameter :: thresh_break = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] - real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] - - ! hydraulics timestep adjustments for acceptable water balance error - integer :: maxiter = 5 ! maximum iterations for timestep reduction [-] - integer :: imult = 3 ! iteration index multiplier [-] - real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] - - ! cohort-specific arrays to hold 1D hydraulics geometric & state variables for entire continuum (leaf,stem,root,soil) - real(r8) :: z_node( n_hypool_tot) ! nodal height of water storage compartments [m] - real(r8) :: z_node_1l( n_hypool_tot) ! nodal height of water storage compartments (single-layer soln) [m] - real(r8) :: v_node( n_hypool_tot) ! volume of water storage compartments [m3] - real(r8) :: v_node_1l( n_hypool_tot) ! volume of water storage compartments (single-layer soln) [m3] - real(r8) :: psi_node( n_hypool_tot) ! water potential in water storage compartments [MPa] - real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] - real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] - real(r8) :: flc_min_node( n_hypool_tot-nshell)! minimum attained fractional loss of conductivity (for xylem refilling dynamics) [-] - real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] - real(r8) :: ths_node( n_hypool_tot) ! saturated volumetric water in water storage compartments [m3 m-3] - real(r8) :: ths_node_1l( n_hypool_tot) ! saturated volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: thr_node( n_hypool_tot) ! residual volumetric water in water storage compartments [m3 m-3] - real(r8) :: thr_node_1l( n_hypool_tot) ! residual volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: the_node( n_hypool_tot) ! error resulting from supersaturation or below-residual th_node [m3 m-3] - real(r8) :: the_node_1l( n_hypool_tot) ! like the_node(:) but for specific single soil layer [m3 m-3] - real(r8) :: th_node( n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] - real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: dth_node( n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] - real(r8) :: dth_node_1l( n_hypool_tot) ! like dth_node_1l(:) but for specific single soil layer [m3 m-3] - real(r8) :: kmax_bound( n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] - real(r8) :: kmax_bound_1l(n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments (single-layer soln) [kg s-1 MPa-1] - real(r8) :: kmax_upper( n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] - real(r8) :: kmax_upper_1l(n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary (single-layer soln) [kg s-1 MPa-1] - real(r8) :: kmax_lower( n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - real(r8) :: kmax_lower_1l(n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary (single-layer soln) [kg s-1 MPa-1] - real(r8) :: hdiff_bound_1l( nshell+1) ! - real(r8) :: k_bound_1l( nshell+1) ! - real(r8) :: dhdiffdpsi0_1l( nshell+1) ! - real(r8) :: dhdiffdpsi1_1l( nshell+1) ! - real(r8) :: dkbounddpsi0_1l(nshell+1) ! - real(r8) :: dkbounddpsi1_1l(nshell+1) ! - real(r8) :: l_aroot_tot_coh ! total length of absorbing roots across all soil layers (cohort) [m] - real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] - - ! column-specific arrays to hold rhizosphere geometric & state variables - real(r8) :: h2osoi_liqvol - real(r8) :: dz_tot ! total soil depth (to bottom of bottom layer) [m] - real(r8) :: l_aroot_tot_col ! total length of absorbing roots across all soil layers [m] - real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] - real(r8) :: ths_shell_1D(nshell) ! saturated water content of rhizosphere compartment [m3 m-3] - real(r8) :: thr_shell_1D(nshell) ! residual water content of rhizosphere compartment [m3 m-3] - real(r8) :: kmax_bound_shell_1l(nshell) ! like kmax_bound_shell_1D(:) but for specific single soil layer [kg s-1 MPa-1] - real(r8) :: psi_node_shell_1D(nshell) ! soil matric potential of rhizosphere compartment [MPa] - real(r8) :: ths_aroot_1D ! saturated water content of 1D representation of fine roots [m3 m-3] - real(r8) :: thr_aroot_1D ! residual water content of 1D representation of fine roots [m3 m-3] - real(r8) :: vtot_aroot_1D ! sum of fine root volume across soil layers [m3] - real(r8) :: psi_node_aroot_1D ! water potential of absorbing root [MPa] - - ! hydraulics conductances - real(r8) :: kmax_bound_bylayershell(nlevsoi_hyd_max,nshell) ! maximum conductance at shell boundaries in each layer [kg s-1 MPa-1] - real(r8) :: kmax_bound_aroot_soil1 ! maximum radial conductance of absorbing roots [kg s-1 MPa-1] - real(r8) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] - real(r8) :: ksoil_bylayer(nlevsoi_hyd_max) ! total rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: ksoil_tot ! total rhizosphere conductance (over all shells and soil layers [MPa] - real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] - real(r8) :: kmax_stem ! maximum whole-stem (above troot to leaf) conductance [kg s-1 MPa-1] - - ! hydraulics other - integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered - real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] - real(r8) :: qflx_tran_veg_patch_coh - real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch - real(r8) :: qtop_dt - real(r8) :: dqtopdth_dthdt - real(r8) :: sapflow - real(r8) :: rootuptake - real(r8) :: totalrootuptake !total root uptake per unit area (kg h2o m-2 time step -1) - real(r8) :: totaldqtopdth_dthdt - real(r8) :: totalqtop_dt !total transpriation per unit area (kg h2o m-2 time step -1) - real(r8) :: total_e !mass balance error (kg h2o m-2 time step -1) - integer :: ncoh_col ! number of cohorts across all non-veg patches within a column - real(r8) :: transp_col ! Column mean transpiration rate [mm H2O/m2] - ! as defined by the input boundary condition - real(r8) :: transp_col_check ! Column mean transpiration rate [mm H2O/m2] as defined - ! by the sum of water fluxes through the cohorts - - real(r8) :: patch_wgt ! fraction of current patch relative to the whole site - ! note that this is almost but not quite cpatch%area/AREA - ! as it regards the fraction of canopy area as the relevant - ! area, and assumes that the HLM has it's own patch - ! that is not tracked by FATES which accounts for all - ! non-canopy areas across all patches - - real(r8) :: smp ! temporary for matric potential (MPa) - integer :: tmp - real(r8) :: tmp1 - real(r8) :: watres_local - integer :: pick_1l(nshell+1) = (/(k,k=n_hypool_ag+n_hypool_troot+1,n_hypool_tot,1)/) - real(r8) :: lwpdiff1, lwpdiff2, Rndiff1, Rndiff2, btran_prev - logical :: mono_decr_Rn ! flag indicating whether net Radiation is monotonically decreasing - real(r8) :: refill_rate ! rate of xylem refilling [fraction per unit time; s-1] - real(r8) :: roota, rootb ! parameters for root distribution [m-1] - real(r8) :: rootfr ! root fraction at different soil layers - real(r8) :: prev_h2oveg ! previous time step plant water storage (kg/m2) - logical :: recruitflag ! flag to check if there is newly recruited cohorts - - type(ed_site_hydr_type), pointer :: site_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - integer :: err_code = 0 - - ! ---------------------------------------------------------------------------------- - ! Important note: We are interested in calculating the total fluxes in and out of the - ! site/column. Usually, when we do things like this, we acknowledge that FATES - ! does not consider the bare ground patch. However, since this routine - ! calculates "column level" fluxes, we have to factor in that patch-level fluxes - ! are only accounting for a portion of the area. - ! ---------------------------------------------------------------------------------- - - ! DEPRECATED: waterstate_inst%psisoi_liq_shell - ! Input: [real(r8) (:,:,:)] soil matric potential (MPa) by layer and rhizosphere shell - - !for debug only - !nstep = get_nstep() - - !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake - call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - - !update water storage in veg after incorporating newly recuited cohorts - if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) - - do s = 1, nsites - - site_hydr => sites(s)%si_hydr - - ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN - dth_layershell_col(:,:) = 0._r8 - site_hydr%dwat_veg = 0._r8 - site_hydr%errh2o_hyd = 0._r8 - prev_h2oveg = site_hydr%h2oveg - ncoh_col = 0 - - ! Calculate the mean site level transpiration flux - ! This is usefull to check on mass conservation - ! of cohort level fluxes - ! ------------------------------------------------- - ifp = 0 - cpatch => sites(s)%oldest_patch - transp_col = 0.0_r8 - do while (associated(cpatch)) - ifp = ifp + 1 - patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area/AREA) - transp_col = transp_col + bc_in(s)%qflx_transp_pa(ifp)*patch_wgt - cpatch => cpatch%younger - end do - - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp = ifp + 1 - - ! ----------------------------------------------------------------------------- - ! We apparently want to know the area fraction of - ! contribution of this patch to the site/column - ! In the interface: - ! wt_ed(p) = this%fates(nc)%bc_out(s)%canopy_fraction_pa(ifp) - ! and then in patch%wtcol(p) = patch%wt_ed(p) - ! - ! From EDCanopyStructureMode.F90:update_hlm_dynamics(): - ! bc_out(s)%canopy_fraction_pa(ifp) = min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area) * & - ! (currentPatch%area/AREA) - ! ---------------------------------------------------------------------------- - - patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area/AREA) - - ! Total volume transpired from this patch [mm H2O / m2 /s ] * [m2/patch] = [mm H2O / patch / s] -! qflx_trans_patch_vol = bc_in(s)%qflx_transp_pa(ifp) * (patch_wgt * AREA) - -! do t=2, numLWPmem -! cpatch_hydr%netRad_mem(t-1) = cpatch_hydr%netRad_mem(t) -! end do -! cpatch_hydr%netRad_mem(numLWPmem) = bc_in(s)%swrad_net_pa(ifp) - bc_in(s)%lwrad_net_pa(ifp) - - gscan_patch = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - gscan_patch = gscan_patch + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo !cohort - - ! The HLM predicted transpiration flux even though no leaves are present? - if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft - ncoh_col = ncoh_col + 1 - ccohort_hydr%qtop_dt = 0._r8 - ccohort_hydr%dqtopdth_dthdt = 0._r8 - ccohort_hydr%sapflow = 0._r8 - ccohort_hydr%rootuptake = 0._r8 - - ! Relative transpiration of this cohort from the whole patch - ! [mm H2O/cohort/s] = [mm H2O / patch / s] / [cohort/patch] - - if(ccohort%g_sb_laweight>nearzero) then - qflx_tran_veg_patch_coh = bc_in(s)%qflx_transp_pa(ifp) * ccohort%g_sb_laweight/gscan_patch - - qflx_tran_veg_indiv = qflx_tran_veg_patch_coh * cpatch%area* & - min(1.0_r8,cpatch%total_canopy_area/cpatch%area)/ccohort%n !AREA / ccohort%n - else - qflx_tran_veg_patch_coh = 0._r8 - qflx_tran_veg_indiv = 0._r8 - end if - - - call updateWaterDepTreeHydProps(sites(s),ccohort,bc_in(s)) - - if(site_hydr%nlevsoi_hyd > 1) then - ! BUCKET APPROXIMATION OF THE SOIL-ROOT HYDRAULIC GRADIENT (weighted average across layers) - !call map2d_to_1d_shells(soilstate_inst, waterstate_inst, g, c, rs1(c,1), ccohort_hydr%l_aroot_layer*ccohort%n, & - ! (2._r8 * ccohort_hydr%kmax_treebg_layer(:)), ths_shell_1D, & - ! thr_shell_1D, psi_node_shell_1D, & - ! r_out_shell_1D, r_node_shell_1D, v_shell_1D, dz_tot, & - ! ksoil_bylayer, ksoil_tot, kmax_bound_bylayershell) - !psi_node( (n_hypool_tot-nshell+1):n_hypool_tot) = psi_node_shell_1D(:) - ! REPRESENTATIVE SINGLE FINE ROOT POOL (weighted average across layers) - !call map2d_to_1d_aroot(ft, ccohort, kmax_bound_bylayershell, ths_aroot_1D, thr_aroot_1D, vtot_aroot_1D, psi_node_aroot_1D) - !psi_node(n_hypool_ag+n_hypool_troot+1) = psi_node_aroot_1D - else if(site_hydr%nlevsoi_hyd == 1) then - write(fates_log(),*) 'Single layer hydraulics currently inoperative nlevsoi_hyd==1' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !psi_node( (n_hypool_tot-nshell+1):n_hypool_tot) = psisoi_liq_shell(c,1,:) - !psi_node( n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%psi_aroot(1) - !flc_min_node(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%flc_min_aroot(1) - end if - - ! SET NODE HEIGHTS AND VOLUMES - z_node( 1 : n_hypool_ag) = ccohort_hydr%z_node_ag(:) ! leaf and stem - z_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) = ccohort_hydr%z_node_troot(:) ! transporting root - z_node((n_hypool_ag+n_hypool_troot+1): n_hypool_tot) = ccohort_hydr%z_node_aroot(1) ! absorbing root and rhizosphere shells - v_node( 1 : n_hypool_ag) = ccohort_hydr%v_ag(:) ! leaf and stem - v_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) = ccohort_hydr%v_troot(:) ! transporting root - if(site_hydr%nlevsoi_hyd == 1) then - v_node((n_hypool_ag+n_hypool_troot+1) ) = ccohort_hydr%v_aroot_tot ! absorbing root - v_node( (n_hypool_tot-nshell+1): n_hypool_tot) = & - site_hydr%v_shell_1D(:)*ccohort_hydr%l_aroot_tot/sum(bc_in(s)%dz_sisl(:)) ! rhizosphere shells - end if - - ! SET SATURATED & RESIDUAL WATER CONTENTS - if(site_hydr%nlevsoi_hyd == 1) then - ths_node( (n_hypool_tot-nshell+1):n_hypool_tot) = bc_in(s)%watsat_sisl(1) - !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter 1 - ! introduced for the van Genuchten, but does not exist for Campbell SWC. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! thr_node( (n_hypool_tot-nshell+1):n_hypool_tot) = bc_in(s)%watres_sisl(1) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav*1.e-9_r8, & - (-1._r8)*bc_in(s)%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & - bc_in(s)%bsw_sisl(1), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in(s)%watsat_sisl(1), & - watres_local) - thr_node( (n_hypool_tot-nshell+1):n_hypool_tot) = watres_local - case default - end select - end if - do k=1,n_hypool_ag+n_hypool_troot+1 - ths_node(k) = EDPftvarcon_inst%hydr_thetas_node(ft,porous_media(k)) - thr_node(k) = EDPftvarcon_inst%hydr_thetas_node(ft,porous_media(k)) * & - EDPftvarcon_inst%hydr_resid_node(ft,porous_media(k)) - enddo - - ! SET BOUNDARY MAX CONDUCTANCES - !! assign cohort-level conductances to the 1D array - kmax_bound( : ) = 0._r8 - kmax_lower( : ) = 0._r8 - kmax_upper( : ) = 0._r8 - kmax_bound( 1 : n_hypool_ag ) = ccohort_hydr%kmax_bound(:) - kmax_upper( 1 : n_hypool_ag ) = ccohort_hydr%kmax_upper(:) - kmax_lower( 1 : n_hypool_ag ) = ccohort_hydr%kmax_lower(:) - kmax_upper(( n_hypool_ag+1) ) = ccohort_hydr%kmax_upper_troot - if(site_hydr%nlevsoi_hyd == 1) then - site_hydr%kmax_upper_shell_1D(1) = ccohort_hydr%kmax_innershell(1) - site_hydr%kmax_lower_shell_1D(1) = ccohort_hydr%kmax_innershell(1) - site_hydr%kmax_bound_shell_1D(1) = ccohort_hydr%kmax_innershell(1) - !! estimate troot-aroot and aroot-radial components as a residual: - !! 25% each of total (surface of aroots to leaves) resistance - kmax_bound(( n_hypool_ag+1):(n_hypool_ag+2 )) = 2._r8 * ccohort_hydr%kmax_treebg_tot - kmax_lower(( n_hypool_ag+1) ) = 2._r8 * kmax_bound(n_hypool_ag+1) - kmax_upper(( n_hypool_ag+2) ) = 2._r8 * kmax_bound(n_hypool_ag+1) - kmax_lower(( n_hypool_ag+2) ) = 2._r8 * ccohort_hydr%kmax_treebg_tot - kmax_bound_aroot_soil1 = kmax_bound(n_hypool_ag+2) - kmax_bound_aroot_soil2 = site_hydr%kmax_bound_shell_1D(1) * & - ccohort_hydr%l_aroot_tot / site_hydr%l_aroot_1D - kmax_bound(( n_hypool_ag+2) ) = 1._r8/(1._r8/kmax_bound_aroot_soil1 + & - 1._r8/kmax_bound_aroot_soil2) - kmax_bound((n_hypool_tot-nshell+1):(n_hypool_tot-1)) = site_hydr%kmax_bound_shell_1D(2:nshell) * & - ccohort_hydr%l_aroot_tot / site_hydr%l_aroot_1D - kmax_upper((n_hypool_tot-nshell+1):(n_hypool_tot )) = site_hydr%kmax_upper_shell_1D(1:nshell) * & - ccohort_hydr%l_aroot_tot / site_hydr%l_aroot_1D - kmax_lower((n_hypool_tot-nshell+1):(n_hypool_tot )) = site_hydr%kmax_lower_shell_1D(1:nshell) * & - ccohort_hydr%l_aroot_tot / site_hydr%l_aroot_1D - end if - - if(site_hydr%nlevsoi_hyd == 1) then - ! CONVERT WATER POTENTIALS TO WATER CONTENTS FOR THE NEW 'BUCKET' - ! RHIZOSPHERE (fine roots and rhizosphere shells) - do k = (n_hypool_tot - nshell), n_hypool_tot - call th_from_psi(ft, porous_media(k), psi_node(k), th_node(k),site_hydr,bc_in(s)) - enddo !aroot thru outer rhiz shell - end if - ! MAP REMAINING WATER CONTENTS (leaf, stem, troot) TO THE 1D ARRAY - th_node( 1 : n_hypool_ag ) = ccohort_hydr%th_ag(:) - th_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) = ccohort_hydr%th_troot(:) - flc_min_node( 1 : n_hypool_ag ) = ccohort_hydr%flc_min_ag(:) - flc_min_node((n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) = ccohort_hydr%flc_min_troot(:) - - mono_decr_Rn = .true. -! do t=2, numLWPmem -! if((cpatch_hydr%netRad_mem(t) - cpatch_hydr%netRad_mem(t-1)) >= 0._r8) then - mono_decr_Rn = .false. -! EXIT -! end if -! end do - - if(site_hydr%nlevsoi_hyd == 1) then - ! 1-D THETA-BASED SOLUTION TO RICHARDS' EQUATION - call Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, & - thr_node, kmax_bound, kmax_upper, kmax_lower, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & - th_node, flc_min_node, qflx_tran_veg_indiv, & - thresh, thresh_break, maxiter, imult, dtime, & - dth_node, the_node, we_area_outer, qtop_dt, dqtopdth_dthdt, & - sapflow, rootuptake, small_theta_num, & - mono_decr_Rn, site_hydr, bc_in(s)) - - ccohort_hydr%errh2o = we_area_outer ! kg/m2 ground/individual - ccohort_hydr%qtop_dt = qtop_dt - ccohort_hydr%dqtopdth_dthdt = dqtopdth_dthdt - ccohort_hydr%sapflow = sapflow - ccohort_hydr%rootuptake = rootuptake - - ! UPDATE WATER CONTENT & POTENTIAL IN LEAVES, STEM, AND TROOT (COHORT-LEVEL) [[NOW THIS IS DONE BELOW]] - !do k=1,n_hypool_ag - ! ccohort_hydr%th_ag(k) = th_node(k) - ! call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), ccohort_hydr%psi_ag(k)) - !enddo - !do k=(n_hypool_ag+1),(n_hypool_ag+n_hypool_troot) - ! ccohort_hydr%th_troot(k-n_hypool_ag) = th_node(k) - ! call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot(k-n_hypool_ag), ccohort_hydr%psi_troot(k-n_hypool_ag)) - !enddo - ccohort_hydr%th_aroot(1) = th_node(n_hypool_ag+n_hypool_troot+n_hypool_aroot) - call psi_from_th(ft, 4, ccohort_hydr%th_aroot(1), ccohort_hydr%psi_aroot(1), site_hydr, bc_in(s)) - dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot) * & - v_node(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot)*denh2o) - - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n/AREA !*patch_wgt - - site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n/AREA !*patch_wgt - !site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + ccohort_hydr%errh2o*(ccohort%c_area / ccohort%n)/AREA !*patch_wgt - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + ccohort_hydr%errh2o*ccohort%c_area /AREA !*patch_wgt - - ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL - dth_layershell_col(site_hydr%nlevsoi_hyd,:) = dth_layershell_col(site_hydr%nlevsoi_hyd,:) + & - dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & - ccohort_hydr%l_aroot_tot * ccohort%n / site_hydr%l_aroot_1D! * & - !patch_wgt - else if(site_hydr%nlevsoi_hyd > 1) then - ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS - ! _____ - ! | | - ! |leaf | - ! |_____| - ! / - ! \ - ! / - ! __\__ - ! | | - ! |stem | - ! |_____| - !------/----------------_____--------------------------------- - ! \ | | | | | | | - ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 - ! \ _/ |_____| | | k-1 | k | k+1 | - !------/------_/--------_____-------------------------------------- - ! \ _/ | | | | | | | - ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j - ! | |_/ |_____| | | k-1 | k | k+1 | - !---|troot|-------------_____---------------------------------------------- - ! |_____|\_ | | | | | | | - ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 - ! |_____| | | k-1 | k | k+1 | - !--------------------------------------------------------------------------- - ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, - ! each of which encompass all plant nodes and soil nodes for a given soil layer j, - ! with the timestep fraction for each layer-specific solution proportional to each - ! layer's contribution to the total root-soil conductance - ! Water potential in plant nodes is updated after each solution - ! As such, the order across soil layers in which the solution is conducted matters. - ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance - ! NET EFFECT: total water removed from plant-soil system remains the same: it - ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) - ! root water uptake in each layer is proportional to each layer's total - ! root length density and soil matric potential - ! root hydraulic redistribution emerges within this sequence when a - ! layers have transporting-to-absorbing root water potential gradients of opposite sign - kbg_layer(:) = 0._r8 - kbg_tot = 0._r8 - do j=1,site_hydr%nlevsoi_hyd - z_node_1l((n_hypool_ag+n_hypool_troot+1):(n_hypool_tot)) = bc_in(s)%z_sisl(j) - v_node_1l((n_hypool_ag+n_hypool_troot+1) ) = ccohort_hydr%v_aroot_layer(j) - v_node_1l((n_hypool_tot-nshell+1):(n_hypool_tot)) = site_hydr%v_shell(j,:) * & - ccohort_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j) - site_hydr%kmax_bound_shell(j,1)=ccohort_hydr%kmax_innershell(j) - site_hydr%kmax_upper_shell(j,1)=ccohort_hydr%kmax_innershell(j) - site_hydr%kmax_lower_shell(j,1)=ccohort_hydr%kmax_innershell(j) - kmax_bound_1l(:) = 0._r8 - kmax_bound_shell_1l(:) = site_hydr%kmax_bound_shell(j,:) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - - - ! transporting-to-absorbing root conductance: factor of 2 means one-half of the total - ! belowground resistance in layer j - kmax_bound_1l((n_hypool_ag+1)) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - ! transporting-to-absorbing root conductance: factor of 2*2 means one-half of the total - ! belowground resistance in layer j, split in half between transporting and absorbing root - kmax_lower_1l(n_hypool_ag+1) = 4._r8 * ccohort_hydr%kmax_treebg_layer(j) - ! radial absorbing root conductance: factor of 2 means one-half of the - ! total belowground resistance in layer j - kmax_bound_aroot_soil1 = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - ! (root surface)-to-(soil shell#1) conductance - kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) - ! combined (soil shell#1)-to-(absorbing root) conductance - - kmax_bound_1l(n_hypool_ag+2) = 1._r8/(1._r8/kmax_bound_aroot_soil1 + & - 1._r8/kmax_bound_aroot_soil2) - kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) - kmax_lower_1l(n_hypool_ag+2) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - ! REMEMBER: kmax_bound_shell_1l defined at the uppper (closer to atmosphere) - ! boundary for each node, while kmax_bound_1l defined at the lower - ! (closer to bulk soil) boundary for each node - kmax_bound_1l(n_hypool_tot-nshell+1:n_hypool_tot-1) = kmax_bound_shell_1l(2:nshell) - kmax_upper_1l(n_hypool_tot-nshell+1:n_hypool_tot) = & - site_hydr%kmax_upper_shell(j,1:nshell) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - - kmax_lower_1l(n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%kmax_lower_shell(j,1:nshell) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - - th_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%th_aroot(j) - - th_node_1l(n_hypool_ag+n_hypool_troot+2:n_hypool_tot) = & - site_hydr%h2osoi_liqvol_shell(j,1:nshell) - - psi_node_1l( :) = fates_huge - flc_node_1l( :) = fates_huge - dflcdpsi_node_1l(:) = fates_huge - do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - call psi_from_th(ft, porous_media(k), th_node_1l(k), & - psi_node_1l(k),site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(k), psi_node_1l(k), & - flc_node_1l(k), site_hydr, bc_in(s)) - call dflcdpsi_from_psi(ft, porous_media(k), psi_node_1l(k), & - dflcdpsi_node_1l(k), site_hydr, bc_in(s)) - enddo - hdiff_bound_1l( :) = fates_huge - k_bound_1l( :) = fates_huge - dhdiffdpsi0_1l( :) = fates_huge - dhdiffdpsi1_1l( :) = fates_huge - dkbounddpsi0_1l( :) = fates_huge - dkbounddpsi1_1l( :) = fates_huge - - ! Get k_bound_1l - call boundary_hdiff_and_k(1, z_node_1l(pick_1l), psi_node_1l(pick_1l), & - flc_node_1l(pick_1l), dflcdpsi_node_1l(pick_1l), & - kmax_bound_1l(pick_1l), kmax_upper_1l(pick_1l), & - kmax_lower_1l(pick_1l), hdiff_bound_1l, k_bound_1l, dhdiffdpsi0_1l, & - dhdiffdpsi1_1l, dkbounddpsi0_1l, dkbounddpsi1_1l, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) - !! upper bound limited to size()-1 b/c of zero-flux outer boundary condition - kbg_layer(j) = 1._r8/sum(1._r8/k_bound_1l(1:(size(k_bound_1l)-1))) - kbg_tot = kbg_tot + kbg_layer(j) - - enddo !soil layer - - ! order soil layers in terms of decreasing volumetric water content - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - do j = site_hydr%nlevsoi_hyd-1,1,-1 - do jj = 1,j - if (kbg_layer(ordered(jj)) <= kbg_layer(ordered(jj+1))) then - tmp = ordered(jj) - ordered(jj) = ordered(jj+1) - ordered(jj+1) = tmp - end if - enddo - enddo - - !initialize state variables in leaves to transporting roots - z_node_1l (1:n_hypool_ag+n_hypool_troot) = z_node(1:n_hypool_ag+n_hypool_troot) - v_node_1l (1:n_hypool_ag+n_hypool_troot) = v_node(1:n_hypool_ag+n_hypool_troot) - ths_node_1l (1:n_hypool_ag+n_hypool_troot+1) = ths_node(1:n_hypool_ag+n_hypool_troot+1) - thr_node_1l (1:n_hypool_ag+n_hypool_troot+1) = thr_node(1:n_hypool_ag+n_hypool_troot+1) - kmax_bound_1l (1:n_hypool_ag) = kmax_bound(1:n_hypool_ag) - kmax_upper_1l (1:n_hypool_ag+1) = kmax_upper(1:n_hypool_ag+1) - kmax_lower_1l (1:n_hypool_ag) = kmax_lower(1:n_hypool_ag) - th_node_1l (1:n_hypool_ag+n_hypool_troot) = th_node(1:n_hypool_ag+n_hypool_troot) - ccohort_hydr%errh2o = 0._r8 - ! do j=1,nlevsoi_hyd ! replace j with ordered(jj) in order - ! to go through soil layers in order of decreasing total root-soil conductance - do jj=1,site_hydr%nlevsoi_hyd - - !initialize state variables in absorbing roots and rhizosphere shells in each soil layer - !z_node_1l( ( n_hypool_ag+1):(n_hypool_troot )) = -bc_in(s)%z_sisl(ordered(jj)) - !! BOC...ad-hoc assume no grav difference bewtween aroot and troot for each layer - - z_node_1l (n_hypool_ag+n_hypool_troot+1:n_hypool_tot) = -bc_in(s)%z_sisl(ordered(jj)) - v_node_1l (n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%v_aroot_layer(ordered(jj)) - v_node_1l (n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%v_shell(ordered(jj),:) * & - ccohort_hydr%l_aroot_layer(ordered(jj))/& - bc_in(s)%dz_sisl(ordered(jj)) - ths_node_1l(n_hypool_tot-nshell+1:n_hypool_tot) = bc_in(s)%watsat_sisl(ordered(jj)) - - !! BOC... should the below code exist on HLM side? watres_col is a new - !! SWC parameter introduced for the van Genuchten, but does not exist for Campbell SWC. - - select case (iswc) - case (van_genuchten) - write(fates_log(),*) & - 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! thr_node_1l( (n_hypool_tot-nshell+1):(n_hypool_tot )) = bc_in(s)%watres_sisl(ordered(jj)) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav*1.e-9_r8, & - (-1._r8)*bc_in(s)%sucsat_sisl(ordered(jj))*denh2o*grav*1.e-9_r8, & - bc_in(s)%bsw_sisl(ordered(jj)), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in(s)%watsat_sisl(ordered(jj)), & - watres_local) - thr_node_1l( (n_hypool_tot-nshell+1):(n_hypool_tot )) = watres_local - case default - end select - - kmax_bound_shell_1l(:) = site_hydr%kmax_bound_shell(ordered(jj),:) * & - ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) - - kmax_bound_1l(n_hypool_ag+1) = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) - - ! transporting-to-absorbing root conductance: factor of 2 means - ! one-half of the total belowground resistance in layer j - kmax_lower_1l(n_hypool_ag+1) = 4.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) - - ! transporting-to-absorbing root conductance: factor of 2*2 means one-half of the total - ! belowground resistance in layer j, split in half between transporting and absorbing root - kmax_bound_aroot_soil1 = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) - - ! radial absorbing root conductance: factor of 2 means one-half of - ! the total belowground resistance in layer j - kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) - - ! (root surface)-to-(soil shell#1) conductance - kmax_bound_1l(n_hypool_ag+2) = 1.0_r8 / & - (1._r8/kmax_bound_aroot_soil1 + 1._r8/kmax_bound_aroot_soil2) - - ! combined (soil shell#1)-to-(absorbing root) conductance - kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) - kmax_lower_1l(n_hypool_ag+2) = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) - kmax_bound_1l(n_hypool_tot-nshell+1:n_hypool_tot-1) = kmax_bound_shell_1l(2:nshell) - - ! REMEMBER: kmax_bound_shell_1l defined at the uppper - ! (closer to atmosphere) boundary for each node, while kmax_bound_1l - ! defined at the lower (closer to bulk soil) boundary for each node - kmax_upper_1l((n_hypool_tot-nshell+1 ):(n_hypool_tot )) = & - site_hydr%kmax_upper_shell(ordered(jj),1:nshell) * & - ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) - kmax_lower_1l((n_hypool_tot-nshell+1 ):(n_hypool_tot )) = & - site_hydr%kmax_lower_shell(ordered(jj),1:nshell) * & - ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) - - flc_min_node(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%flc_min_aroot(ordered(jj)) - th_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%th_aroot(ordered(jj)) - th_node_1l(n_hypool_ag+n_hypool_troot+2:n_hypool_tot) = site_hydr%h2osoi_liqvol_shell(ordered(jj),:) - - ! the individual-layer Richards' equation solution - call Hydraulics_1DSolve(ccohort, ft, & - z_node_1l, v_node_1l, ths_node_1l, thr_node_1l, & - kmax_bound_1l, kmax_upper_1l, kmax_lower_1l, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & - th_node_1l, flc_min_node, qflx_tran_veg_indiv, & - thresh, thresh_break, maxiter, imult, & - dtime*kbg_layer(ordered(jj))/kbg_tot, & - dth_node_1l, the_node_1l, we_area_outer, qtop_dt, & - dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, & - mono_decr_Rn, site_hydr, bc_in(s)) - - dwat_veg_coh = & - sum(dth_node_1l(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot)* & - v_node_1l(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot)*denh2o) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n/AREA!*patch_wgt - site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n/AREA!*patch_wgt - ccohort_hydr%errh2o = ccohort_hydr%errh2o + we_area_outer - !! kg/m2 ground/individual - - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + & - we_area_outer*ccohort%c_area /AREA!*patch_wgt - !we_area_outer*(ccohort%c_area / ccohort%n)/AREA!*patch_wgt - ccohort_hydr%qtop_dt = ccohort_hydr%qtop_dt + qtop_dt ! - ccohort_hydr%dqtopdth_dthdt = ccohort_hydr%dqtopdth_dthdt + dqtopdth_dthdt ! - ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow ! - ccohort_hydr%rootuptake = ccohort_hydr%rootuptake + rootuptake ! - SELECT CASE (ordered(jj)) !! select soil layer - CASE (1) - ccohort_hydr%rootuptake01 = rootuptake - CASE (2) - ccohort_hydr%rootuptake02 = rootuptake - CASE (3) - ccohort_hydr%rootuptake03 = rootuptake - CASE (4) - ccohort_hydr%rootuptake04 = rootuptake - CASE (5) - ccohort_hydr%rootuptake05 = rootuptake - CASE (6) - ccohort_hydr%rootuptake06 = rootuptake - CASE (7) - ccohort_hydr%rootuptake07 = rootuptake - CASE (8) - ccohort_hydr%rootuptake08 = rootuptake - CASE (9) - ccohort_hydr%rootuptake09 = rootuptake - CASE (10) - ccohort_hydr%rootuptake10 = rootuptake - CASE DEFAULT - end SELECT - - ! UPDATE WATER CONTENT & POTENTIAL IN AROOT (COHORT-LEVEL) - ccohort_hydr%th_aroot(ordered(jj)) = th_node_1l(n_hypool_ag+n_hypool_troot+1) - call psi_from_th(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & - ccohort_hydr%th_aroot(ordered(jj)), ccohort_hydr%psi_aroot(ordered(jj)), & - site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & - ccohort_hydr%psi_aroot(ordered(jj)), ccohort_hydr%flc_aroot(ordered(jj)), & - site_hydr, bc_in(s)) - - ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL - dth_layershell_col(ordered(jj),:) = dth_layershell_col(ordered(jj),:) + & - dth_node_1l((n_hypool_tot-nshell+1):n_hypool_tot) * & - ccohort_hydr%l_aroot_layer(ordered(jj)) * & - ccohort%n / site_hydr%l_aroot_layer(ordered(jj)) !* & - !patch_wgt - enddo !soil layer - end if !nlevsoi_hyd > 1 - - ! UPDATE WATER CONTENT & POTENTIAL IN LEAVES, STEM, AND TROOT (COHORT-LEVEL) - do k=1,n_hypool_ag - if(site_hydr%nlevsoi_hyd == 1) then - ccohort_hydr%th_ag(k) = th_node(k) - else - ccohort_hydr%th_ag(k) = th_node_1l(k) - endif - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k), site_hydr, bc_in(s) ) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%flc_ag(k), site_hydr, bc_in(s) ) - enddo - do k=(n_hypool_ag+1),(n_hypool_ag+n_hypool_troot) - if(site_hydr%nlevsoi_hyd == 1) then - ccohort_hydr%th_troot(k-n_hypool_ag) = th_node(k) - else - ccohort_hydr%th_troot(k-n_hypool_ag) = th_node_1l(k) - endif - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot(k-n_hypool_ag), & - ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot(k-n_hypool_ag), & - ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in(s)) - enddo - - ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP - ! first update the leaf water potential memory - do t=2, numLWPmem - ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) - end do - ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) - call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - - refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 - do k=1,n_hypool_ag - ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) - if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling - ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & - (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) - end if - end do - do k=1,n_hypool_troot - ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) - if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling - ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & - (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) - end if - end do - do j=1,site_hydr%nlevsoi_hyd - ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) - if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling - ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & - (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) - end if - end do - - ccohort => ccohort%shorter - enddo !cohort - - cpatch => cpatch%younger - enddo !patch - - ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) - site_hydr%supsub_flag(:) = 999 - do j=1,site_hydr%nlevsoi_hyd - !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter - ! introduced for the van Genuchten, but does not exist for Campbell SWC. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! watres_local = bc_in(s)%watres_sisl(j) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav*1.e-9_r8, & - (-1._r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in(s)%watsat_sisl(j), & - watres_local) - case default - end select - do k=1,nshell - if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & - (bc_in(s)%watsat_sisl(j)-small_theta_num)) then - site_hydr%supsub_flag(j) = k - site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & - (watres_local+small_theta_num)) then - site_hydr%supsub_flag(j) = -k - site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num - else - site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & - dth_layershell_col(j,k) - end if - enddo + ! ---------------------------------------------------------------------------------- + ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics + ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) + ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 + + ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU + ! + ! BOC...for quick implementation avoided JT's abstract interface, + ! but these should be converted to interfaces in the future + ! ---------------------------------------------------------------------------------- + + ! + ! !DESCRIPTION: + !s + ! !USES: + use EDTypesMod , only : AREA + use FatesUtilsMod , only : check_var_real + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime - ! Update the matric potential in the inner-most shell - ! (used for setting tissue potentials of new recruits) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), smp) - site_hydr%psisoi_liq_innershell(j) = smp + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: sub = 'clm::Hydraulics_bc' + integer :: iv ! leaf layer + integer :: ifp ! index of FATES patch + integer :: s ! index of FATES site + integer :: j,jj! soil layer + integer :: k ! 1D plant-soil continuum array + integer :: ft ! plant functional type index + integer :: t ! previous timesteps (for lwp stability calculation) + integer :: nstep !number of time steps + !---------------------------------------------------------------------- - if(site_hydr%nlevsoi_hyd == 1) then - bc_out(s)%qflx_soil2root_sisl(1:bc_in(s)%nlevsoil-1) = 0._r8 + type (ed_patch_type), pointer :: cpatch + type (ed_cohort_type), pointer :: ccohort - ! qflx_rootsoi(c,bc_in(s)%nlevsoil) = - ! -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) + ! hydraulics global constants - bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell_1D(:)) * & - !site_hydr%l_aroot_1D/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)- & !BOC(10/02/2018)...error - should be plus - site_hydr%l_aroot_1D/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & - site_hydr%recruit_w_uptake(site_hydr%nlevsoi_hyd) + real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] -! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(bc_in(s)%nlevsoil), & -! bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil)/(bc_in(s)%dz_sisl(bc_in(s)%nlevsoil)*denh2o)) - - ! Save the amount of liquid soil water known to the model after root uptake - site_hydr%h2osoi_liq_prev(site_hydr%nlevsoi_hyd) = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - & - dtime*bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) - + ! hydraulics timestep adjustments for acceptable water balance error + + real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] + + ! cohort-specific arrays to hold 1D hydraulics geometric & state variables for entire continuum (leaf,stem,root,soil) + real(r8) :: z_node_1l( n_hypool_tot) ! nodal height of water storage compartments (single-layer soln) [m] + real(r8) :: v_node_1l( n_hypool_tot) ! volume of water storage compartments (single-layer soln) [m3] + real(r8) :: psi_node( n_hypool_tot) ! water potential in water storage compartments [MPa] + real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] + real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] + real(r8) :: flc_min_node( n_hypool_tot-nshell)! minimum attained fractional loss of conductivity (for xylem refilling dynamics) [-] + real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] + real(r8) :: ths_node( n_hypool_tot) ! saturated volumetric water in water storage compartments [m3 m-3] + real(r8) :: ths_node_1l( n_hypool_tot) ! saturated volumetric water in water storage compartments (single-layer soln) [m3 m-3] + real(r8) :: thr_node( n_hypool_tot) ! residual volumetric water in water storage compartments [m3 m-3] + real(r8) :: thr_node_1l( n_hypool_tot) ! residual volumetric water in water storage compartments (single-layer soln) [m3 m-3] + real(r8) :: the_node( n_hypool_tot) ! error resulting from supersaturation or below-residual th_node [m3 m-3] + real(r8) :: the_node_1l( n_hypool_tot) ! like the_node(:) but for specific single soil layer [m3 m-3] + real(r8) :: th_node( n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] + real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] + real(r8) :: dth_node( n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] + real(r8) :: dth_node_1l( n_hypool_tot) ! like dth_node_1l(:) but for specific single soil layer [m3 m-3] + real(r8) :: kmax_bound( n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] + real(r8) :: kmax_bound_1l(n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments (single-layer soln) [kg s-1 MPa-1] + real(r8) :: kmax_upper( n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] + real(r8) :: kmax_upper_1l(n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary (single-layer soln) [kg s-1 MPa-1] + real(r8) :: kmax_lower( n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] + real(r8) :: kmax_lower_1l(n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary (single-layer soln) [kg s-1 MPa-1] + real(r8) :: hdiff_bound_1l( nshell+1) ! + real(r8) :: k_bound_1l( nshell+1) ! + real(r8) :: dhdiffdpsi0_1l( nshell+1) ! + real(r8) :: dhdiffdpsi1_1l( nshell+1) ! + real(r8) :: dkbounddpsi0_1l(nshell+1) ! + real(r8) :: dkbounddpsi1_1l(nshell+1) ! + real(r8) :: l_aroot_tot_coh ! total length of absorbing roots across all soil layers (cohort) [m] + real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] + + ! column-specific arrays to hold rhizosphere geometric & state variables + real(r8) :: h2osoi_liqvol + real(r8) :: dz_tot ! total soil depth (to bottom of bottom layer) [m] + real(r8) :: l_aroot_tot_col ! total length of absorbing roots across all soil layers [m] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: ths_shell_1D(nshell) ! saturated water content of rhizosphere compartment [m3 m-3] + real(r8) :: thr_shell_1D(nshell) ! residual water content of rhizosphere compartment [m3 m-3] + real(r8) :: kmax_bound_shell_1l(nshell) ! like kmax_bound_shell_1D(:) but for specific single soil layer [kg s-1 MPa-1] + real(r8) :: psi_node_shell_1D(nshell) ! soil matric potential of rhizosphere compartment [MPa] + real(r8) :: ths_aroot_1D ! saturated water content of 1D representation of fine roots [m3 m-3] + real(r8) :: thr_aroot_1D ! residual water content of 1D representation of fine roots [m3 m-3] + real(r8) :: vtot_aroot_1D ! sum of fine root volume across soil layers [m3] + real(r8) :: psi_node_aroot_1D ! water potential of absorbing root [MPa] + + ! hydraulics conductances + real(r8) :: kmax_bound_bylayershell(nlevsoi_hyd_max,nshell) ! maximum conductance at shell boundaries in each layer [kg s-1 MPa-1] + real(r8) :: kmax_bound_aroot_soil1 ! maximum radial conductance of absorbing roots [kg s-1 MPa-1] + real(r8) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] + real(r8) :: ksoil_bylayer(nlevsoi_hyd_max) ! total rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: ksoil_tot ! total rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: kmax_stem ! maximum whole-stem (above troot to leaf) conductance [kg s-1 MPa-1] + + ! hydraulics other + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered + real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] + real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch + real(r8) :: qtop_dt + real(r8) :: dqtopdth_dthdt + real(r8) :: sapflow + real(r8) :: rootuptake + real(r8) :: totalrootuptake !total root uptake per unit area (kg h2o m-2 time step -1) + real(r8) :: totaldqtopdth_dthdt + real(r8) :: totalqtop_dt !total transpriation per unit area (kg h2o m-2 time step -1) + real(r8) :: total_e !mass balance error (kg h2o m-2 time step -1) + integer :: ncoh_col ! number of cohorts across all non-veg patches within a column + real(r8) :: transp_col ! Column mean transpiration rate [mm H2O/m2] + ! as defined by the input boundary condition + real(r8) :: transp_col_check ! Column mean transpiration rate [mm H2O/m2] as defined + ! by the sum of water fluxes through the cohorts + + real(r8) :: patch_wgt ! fraction of current patch relative to the whole site + ! note that this is almost but not quite cpatch%area/AREA + ! as it regards the fraction of canopy area as the relevant + ! area, and assumes that the HLM has it's own patch + ! that is not tracked by FATES which accounts for all + ! non-canopy areas across all patches + + real(r8) :: smp ! temporary for matric potential (MPa) + integer :: tmp + real(r8) :: tmp1 + real(r8) :: watres_local + integer :: pick_1l(nshell+1) = (/(k,k=n_hypool_ag+n_hypool_troot+1,n_hypool_tot,1)/) + real(r8) :: lwpdiff1, lwpdiff2, Rndiff1, Rndiff2, btran_prev + real(r8) :: refill_rate ! rate of xylem refilling [fraction per unit time; s-1] + real(r8) :: roota, rootb ! parameters for root distribution [m-1] + real(r8) :: rootfr ! root fraction at different soil layers + real(r8) :: prev_h2oveg ! previous time step plant water storage (kg/m2) + logical :: recruitflag ! flag to check if there is newly recruited cohorts + + type(ed_site_hydr_type), pointer :: site_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + integer :: err_code = 0 + + ! ---------------------------------------------------------------------------------- + ! Important note: We are interested in calculating the total fluxes in and out of the + ! site/column. Usually, when we do things like this, we acknowledge that FATES + ! does not consider the bare ground patch. However, since this routine + ! calculates "column level" fluxes, we have to factor in that patch-level fluxes + ! are only accounting for a portion of the area. + ! ---------------------------------------------------------------------------------- + + ! DEPRECATED: waterstate_inst%psisoi_liq_shell + ! Input: [real(r8) (:,:,:)] soil matric potential (MPa) by layer and rhizosphere shell + + !for debug only + !nstep = get_nstep() + + !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake + call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + + !update water storage in veg after incorporating newly recuited cohorts + if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) + + do s = 1, nsites + + site_hydr => sites(s)%si_hydr + + ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN + dth_layershell_col(:,:) = 0._r8 + site_hydr%dwat_veg = 0._r8 + site_hydr%errh2o_hyd = 0._r8 + prev_h2oveg = site_hydr%h2oveg + ncoh_col = 0 + + ! Calculate the mean site level transpiration flux + ! This is usefull to check on mass conservation + ! of cohort level fluxes + ! ------------------------------------------------- + ifp = 0 + cpatch => sites(s)%oldest_patch + transp_col = 0.0_r8 + do while (associated(cpatch)) + ifp = ifp + 1 + patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area/AREA) + transp_col = transp_col + bc_in(s)%qflx_transp_pa(ifp)*patch_wgt + cpatch => cpatch%younger + end do + + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp = ifp + 1 + + ! ---------------------------------------------------------------------------- + ! Objective: Partition the transpiration flux + ! specfied by the land model to the cohorts. The weighting + ! factor we use to downscale is the cohort combo term: g_sb_laweight + ! This term is the stomatal conductance multiplied by total leaf + ! area. gscan_patch is the sum over all cohorts, used to normalize. + ! ---------------------------------------------------------------------------- + + gscan_patch = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + ccohort_hydr => ccohort%co_hydr + gscan_patch = gscan_patch + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo !cohort + + ! The HLM predicted transpiration flux even though no leaves are present? + if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest + do while(associated(ccohort)) + + ccohort_hydr => ccohort%co_hydr + ft = ccohort%pft + ncoh_col = ncoh_col + 1 + ccohort_hydr%qtop_dt = 0._r8 + ccohort_hydr%dqtopdth_dthdt = 0._r8 + ccohort_hydr%sapflow = 0._r8 + ccohort_hydr%rootuptake = 0._r8 + + ! Relative transpiration of this cohort from the whole patch + ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area + ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] + + if(ccohort%g_sb_laweight>nearzero) then + qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * + (ccohort%g_sb_laweight/gscan_patch)/ccohort%n else - !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) - bc_out(s)%qflx_soil2root_sisl(j) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:)) * & - site_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & - site_hydr%recruit_w_uptake(j) - - ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + qflx_tran_veg_indiv = 0._r8 + end if + + ! Calculate the maximum conductivity of the root-rhizosphere interface + ! which is dependent on the flow gradient. + call KmaxInnerShell(sites(s),ccohort, bc_in(s)%hksat_sisl(:), ccohort_hydr%kmax_innershell(:)) + + ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS + ! _____ + ! | | + ! |leaf | + ! |_____| + ! / + ! \ + ! / + ! __\__ + ! | | + ! |stem | + ! |_____| + !------/----------------_____--------------------------------- + ! \ | | | | | | | + ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 + ! \ _/ |_____| | | k-1 | k | k+1 | + !------/------_/--------_____-------------------------------------- + ! \ _/ | | | | | | | + ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j + ! | |_/ |_____| | | k-1 | k | k+1 | + !---|troot|-------------_____---------------------------------------------- + ! |_____|\_ | | | | | | | + ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 + ! |_____| | | k-1 | k | k+1 | + !--------------------------------------------------------------------------- + + ! Set node heights of the leaf, stem and transporting roots + z_node_1l(1:n_hypool_ag) = ccohort_hydr%z_node_ag(:) ! leaf and stem + z_node_1l(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) = ccohort_hydr%z_node_troot(:) + + v_node_1l(1:n_hypool_ag) = ccohort_hydr%v_ag(:) + v_node_1l(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) = ccohort_hydr%v_troot(:) + + + ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, + ! each of which encompass all plant nodes and soil nodes for a given soil layer j, + ! with the timestep fraction for each layer-specific solution proportional to each + ! layer's contribution to the total root-soil conductance + ! Water potential in plant nodes is updated after each solution + ! As such, the order across soil layers in which the solution is conducted matters. + ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance + ! NET EFFECT: total water removed from plant-soil system remains the same: it + ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) + ! root water uptake in each layer is proportional to each layer's total + ! root length density and soil matric potential + ! root hydraulic redistribution emerges within this sequence when a + ! layers have transporting-to-absorbing root water potential gradients of opposite sign + + kbg_layer(:) = 0._r8 + kbg_tot = 0._r8 + + do j=1,site_hydr%nlevsoi_hyd - ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j) + ! Set node heights of the absorbing root compartment and rhizosphere shells + z_node_1l(n_hypool_ag+n_hypool_troot+1:n_hypool_tot) = bc_in(s)%z_sisl(j) + ! Set the node volume of the absorbing root + v_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%v_aroot_layer(j) + ! Set the node volume of the rhizosphere shells + v_node_1l(n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%v_shell(j,:) * & + ccohort_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j) + + site_hydr%kmax_bound_shell(j,1)=ccohort_hydr%kmax_innershell(j) + site_hydr%kmax_upper_shell(j,1)=ccohort_hydr%kmax_innershell(j) + site_hydr%kmax_lower_shell(j,1)=ccohort_hydr%kmax_innershell(j) + + kmax_bound_1l(:) = 0._r8 + kmax_bound_shell_1l(:) = site_hydr%kmax_bound_shell(j,:) * & + ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) + + + ! transporting-to-absorbing root max conductance: + ! -------------------------------------------------- + ! factor of 2 means one-half of the total + ! belowground resistance in layer j + kmax_bound_1l((n_hypool_ag+1)) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) + ! transporting-to-absorbing root conductance: factor of 2*2 means one-half of the total + ! belowground resistance in layer j, split in half between transporting and absorbing root + kmax_lower_1l(n_hypool_ag+1) = 4._r8 * ccohort_hydr%kmax_treebg_layer(j) + + + ! radial absorbing root conductance: factor of 2 means one-half of the + ! total belowground resistance in layer j + kmax_bound_aroot_soil1 = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) + ! (root surface)-to-(soil shell#1) conductance + kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) + + ! combined (soil shell#1)-to-(absorbing root) conductance + ! ------------------------------------------------------- + kmax_bound_1l(n_hypool_ag+2) = 1._r8/(1._r8/kmax_bound_aroot_soil1 + & + 1._r8/kmax_bound_aroot_soil2) + + kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) + kmax_lower_1l(n_hypool_ag+2) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) + ! REMEMBER: kmax_bound_shell_1l defined at the uppper (closer to atmosphere) + ! boundary for each node, while kmax_bound_1l defined at the lower + ! (closer to bulk soil) boundary for each node + kmax_bound_1l(n_hypool_tot-nshell+1:n_hypool_tot-1) = kmax_bound_shell_1l(2:nshell) + kmax_upper_1l(n_hypool_tot-nshell+1:n_hypool_tot) = & + site_hydr%kmax_upper_shell(j,1:nshell) * & + ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) + + kmax_lower_1l(n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%kmax_lower_shell(j,1:nshell) * & + ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - end if + th_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%th_aroot(j) + + th_node_1l(n_hypool_ag+n_hypool_troot+2:n_hypool_tot) = & + site_hydr%h2osoi_liqvol_shell(j,1:nshell) + + psi_node_1l( :) = fates_huge + flc_node_1l( :) = fates_huge + dflcdpsi_node_1l(:) = fates_huge + do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot + call psi_from_th(ft, porous_media(k), th_node_1l(k), & + psi_node_1l(k),site_hydr, bc_in(s)) + call flc_from_psi(ft, porous_media(k), psi_node_1l(k), & + flc_node_1l(k), site_hydr, bc_in(s)) + call dflcdpsi_from_psi(ft, porous_media(k), psi_node_1l(k), & + dflcdpsi_node_1l(k), site_hydr, bc_in(s)) + enddo + hdiff_bound_1l( :) = fates_huge + k_bound_1l( :) = fates_huge + dhdiffdpsi0_1l( :) = fates_huge + dhdiffdpsi1_1l( :) = fates_huge + dkbounddpsi0_1l( :) = fates_huge + dkbounddpsi1_1l( :) = fates_huge + + ! Get k_bound_1l + ! THIS SHOULD ONLY BE CALLING A SUBSET OF THE FOLLOWING ROUTINE? + + call boundary_hdiff_and_k(1, z_node_1l(pick_1l), psi_node_1l(pick_1l), & + flc_node_1l(pick_1l), dflcdpsi_node_1l(pick_1l), & + kmax_bound_1l(pick_1l), kmax_upper_1l(pick_1l), & + kmax_lower_1l(pick_1l), hdiff_bound_1l, k_bound_1l, dhdiffdpsi0_1l, & + dhdiffdpsi1_1l, dkbounddpsi0_1l, dkbounddpsi1_1l, & + kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + !! upper bound limited to size()-1 b/c of zero-flux outer boundary condition + kbg_layer(j) = 1._r8/sum(1._r8/k_bound_1l(1:(size(k_bound_1l)-1))) + kbg_tot = kbg_tot + kbg_layer(j) + + enddo !soil layer + + ! order soil layers in terms of decreasing volumetric water content + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + do j = site_hydr%nlevsoi_hyd-1,1,-1 + do jj = 1,j + if (kbg_layer(ordered(jj)) <= kbg_layer(ordered(jj+1))) then + tmp = ordered(jj) + ordered(jj) = ordered(jj+1) + ordered(jj+1) = tmp + end if + enddo + enddo - enddo !site_hydr%nlevsoi_hyd - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks + ths_node_1l (1:n_hypool_ag+n_hypool_troot+1) = ths_node(1:n_hypool_ag+n_hypool_troot+1) + thr_node_1l (1:n_hypool_ag+n_hypool_troot+1) = thr_node(1:n_hypool_ag+n_hypool_troot+1) + + kmax_bound_1l (1:n_hypool_ag) = kmax_bound(1:n_hypool_ag) + kmax_upper_1l (1:n_hypool_ag+1) = kmax_upper(1:n_hypool_ag+1) + kmax_lower_1l (1:n_hypool_ag) = kmax_lower(1:n_hypool_ag) + th_node_1l (1:n_hypool_ag+n_hypool_troot) = th_node(1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%errh2o = 0._r8 + ! do j=1,nlevsoi_hyd ! replace j with ordered(jj) in order + ! to go through soil layers in order of decreasing total root-soil conductance + do jj=1,site_hydr%nlevsoi_hyd + + !initialize state variables in absorbing roots and rhizosphere shells in each soil layer + !z_node_1l( ( n_hypool_ag+1):(n_hypool_troot )) = -bc_in(s)%z_sisl(ordered(jj)) + !! BOC...ad-hoc assume no grav_earth difference bewtween aroot and troot for each layer + + z_node_1l (n_hypool_ag+n_hypool_troot+1:n_hypool_tot) = -bc_in(s)%z_sisl(ordered(jj)) + v_node_1l (n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%v_aroot_layer(ordered(jj)) + v_node_1l (n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%v_shell(ordered(jj),:) * & + ccohort_hydr%l_aroot_layer(ordered(jj))/& + bc_in(s)%dz_sisl(ordered(jj)) + ths_node_1l(n_hypool_tot-nshell+1:n_hypool_tot) = bc_in(s)%watsat_sisl(ordered(jj)) + + !! BOC... should the below code exist on HLM side? watres_col is a new + !! SWC parameter introduced for the van Genuchten, but does not exist for Campbell SWC. + + select case (iswc) + case (van_genuchten) + write(fates_log(),*) & + 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! thr_node_1l( (n_hypool_tot-nshell+1):(n_hypool_tot )) = bc_in(s)%watres_sisl(ordered(jj)) + case (campbell) + call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & + (-1._r8)*bc_in(s)%sucsat_sisl(ordered(jj))*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(ordered(jj)), & + tmp1) + call swcCampbell_th_from_satfrac(tmp1, & + bc_in(s)%watsat_sisl(ordered(jj)), & + watres_local) + thr_node_1l( (n_hypool_tot-nshell+1):(n_hypool_tot )) = watres_local + case default + end select + + kmax_bound_shell_1l(:) = site_hydr%kmax_bound_shell(ordered(jj),:) * & + ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) + + kmax_bound_1l(n_hypool_ag+1) = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) + + ! transporting-to-absorbing root conductance: factor of 2 means + ! one-half of the total belowground resistance in layer j + kmax_lower_1l(n_hypool_ag+1) = 4.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) + + ! transporting-to-absorbing root conductance: factor of 2*2 means one-half of the total + ! belowground resistance in layer j, split in half between transporting and absorbing root + kmax_bound_aroot_soil1 = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) + + ! radial absorbing root conductance: factor of 2 means one-half of + ! the total belowground resistance in layer j + kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) + + ! (root surface)-to-(soil shell#1) conductance + kmax_bound_1l(n_hypool_ag+2) = 1.0_r8 / & + (1._r8/kmax_bound_aroot_soil1 + 1._r8/kmax_bound_aroot_soil2) + + ! combined (soil shell#1)-to-(absorbing root) conductance + kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) + kmax_lower_1l(n_hypool_ag+2) = 2.0_r8 * ccohort_hydr%kmax_treebg_layer(ordered(jj)) + kmax_bound_1l(n_hypool_tot-nshell+1:n_hypool_tot-1) = kmax_bound_shell_1l(2:nshell) + + ! REMEMBER: kmax_bound_shell_1l defined at the uppper + ! (closer to atmosphere) boundary for each node, while kmax_bound_1l + ! defined at the lower (closer to bulk soil) boundary for each node + kmax_upper_1l((n_hypool_tot-nshell+1 ):(n_hypool_tot )) = & + site_hydr%kmax_upper_shell(ordered(jj),1:nshell) * & + ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) + kmax_lower_1l((n_hypool_tot-nshell+1 ):(n_hypool_tot )) = & + site_hydr%kmax_lower_shell(ordered(jj),1:nshell) * & + ccohort_hydr%l_aroot_layer(ordered(jj)) / site_hydr%l_aroot_layer(ordered(jj)) + + flc_min_node(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%flc_min_aroot(ordered(jj)) + th_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%th_aroot(ordered(jj)) + th_node_1l(n_hypool_ag+n_hypool_troot+2:n_hypool_tot) = site_hydr%h2osoi_liqvol_shell(ordered(jj),:) + + ! the individual-layer Richards' equation solution + call Hydraulics_1DSolve(ccohort, ft, & + z_node_1l, v_node_1l, ths_node_1l, thr_node_1l, & + kmax_bound_1l, kmax_upper_1l, kmax_lower_1l, & + kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & + th_node_1l, flc_min_node, qflx_tran_veg_indiv, & + dtime*kbg_layer(ordered(jj))/kbg_tot, & + dth_node_1l, the_node_1l, we_area_outer, qtop_dt, & + dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, & + site_hydr, bc_in(s)) + + dwat_veg_coh = & + sum(dth_node_1l(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot)* & + v_node_1l(1:n_hypool_ag+n_hypool_troot+n_hypool_aroot)*denh2o) + + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n/AREA + site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n/AREA + ccohort_hydr%errh2o = ccohort_hydr%errh2o + we_area_outer + !! kg/m2 ground/individual + + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + & + we_area_outer*ccohort%c_area /AREA + + ccohort_hydr%qtop_dt = ccohort_hydr%qtop_dt + qtop_dt ! + ccohort_hydr%dqtopdth_dthdt = ccohort_hydr%dqtopdth_dthdt + dqtopdth_dthdt ! + ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow ! + ccohort_hydr%rootuptake = ccohort_hydr%rootuptake + rootuptake ! + + SELECT CASE (ordered(jj)) !! select soil layer + CASE (1) + ccohort_hydr%rootuptake01 = rootuptake + CASE (2) + ccohort_hydr%rootuptake02 = rootuptake + CASE (3) + ccohort_hydr%rootuptake03 = rootuptake + CASE (4) + ccohort_hydr%rootuptake04 = rootuptake + CASE (5) + ccohort_hydr%rootuptake05 = rootuptake + CASE (6) + ccohort_hydr%rootuptake06 = rootuptake + CASE (7) + ccohort_hydr%rootuptake07 = rootuptake + CASE (8) + ccohort_hydr%rootuptake08 = rootuptake + CASE (9) + ccohort_hydr%rootuptake09 = rootuptake + CASE (10) + ccohort_hydr%rootuptake10 = rootuptake + CASE DEFAULT + end SELECT + + ! UPDATE WATER CONTENT & POTENTIAL IN AROOT (COHORT-LEVEL) + ccohort_hydr%th_aroot(ordered(jj)) = th_node_1l(n_hypool_ag+n_hypool_troot+1) + call psi_from_th(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & + ccohort_hydr%th_aroot(ordered(jj)), ccohort_hydr%psi_aroot(ordered(jj)), & + site_hydr, bc_in(s)) + call flc_from_psi(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & + ccohort_hydr%psi_aroot(ordered(jj)), ccohort_hydr%flc_aroot(ordered(jj)), & + site_hydr, bc_in(s)) + + ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL + dth_layershell_col(ordered(jj),:) = dth_layershell_col(ordered(jj),:) + & + dth_node_1l((n_hypool_tot-nshell+1):n_hypool_tot) * & + ccohort_hydr%l_aroot_layer(ordered(jj)) * & + ccohort%n / site_hydr%l_aroot_layer(ordered(jj)) + + enddo !soil layer + end if !nlevsoi_hyd > 1 + + ! UPDATE WATER CONTENT & POTENTIAL IN LEAVES, STEM, AND TROOT (COHORT-LEVEL) + do k=1,n_hypool_ag + if(site_hydr%nlevsoi_hyd == 1) then + ccohort_hydr%th_ag(k) = th_node(k) + else + ccohort_hydr%th_ag(k) = th_node_1l(k) + endif + call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k), site_hydr, bc_in(s) ) + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & + ccohort_hydr%flc_ag(k), site_hydr, bc_in(s) ) + enddo + do k=(n_hypool_ag+1),(n_hypool_ag+n_hypool_troot) + if(site_hydr%nlevsoi_hyd == 1) then + ccohort_hydr%th_troot(k-n_hypool_ag) = th_node(k) + else + ccohort_hydr%th_troot(k-n_hypool_ag) = th_node_1l(k) + endif + call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot(k-n_hypool_ag), & + ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in(s)) + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot(k-n_hypool_ag), & + ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in(s)) + enddo + + ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP + ! first update the leaf water potential memory + do t=2, numLWPmem + ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) + end do + ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) + call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + + refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 + do k=1,n_hypool_ag + ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) + if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & + ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling + ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & + (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) + end if + end do + do k=1,n_hypool_troot + ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) + if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & + ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling + ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & + (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) + end if + end do + do j=1,site_hydr%nlevsoi_hyd + ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) + if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & + ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling + ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & + (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) + end if + end do + + ccohort => ccohort%shorter + enddo !cohort + + cpatch => cpatch%younger + enddo !patch + + ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) + site_hydr%supsub_flag(:) = 999 + do j=1,site_hydr%nlevsoi_hyd + !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter + ! introduced for the van Genuchten, but does not exist for Campbell SWC. + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! watres_local = bc_in(s)%watres_sisl(j) + case (campbell) + call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & + (-1._r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(j), & + tmp1) + call swcCampbell_th_from_satfrac(tmp1, & + bc_in(s)%watsat_sisl(j), & + watres_local) + case default + end select + do k=1,nshell + if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & + (bc_in(s)%watsat_sisl(j)-small_theta_num)) then + site_hydr%supsub_flag(j) = k + site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num + else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & + (watres_local+small_theta_num)) then + site_hydr%supsub_flag(j) = -k + site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num + else + site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & + dth_layershell_col(j,k) + end if + enddo + + ! Update the matric potential in the inner-most shell + ! (used for setting tissue potentials of new recruits) + call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & + bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(j), smp) + site_hydr%psisoi_liq_innershell(j) = smp + + + if(site_hydr%nlevsoi_hyd == 1) then + + bc_out(s)%qflx_soil2root_sisl(1:bc_in(s)%nlevsoil-1) = 0._r8 + + bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell_1D(:)) * & + site_hydr%l_aroot_1D/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & + site_hydr%recruit_w_uptake(site_hydr%nlevsoi_hyd) + + ! Save the amount of liquid soil water known to the model after root uptake + site_hydr%h2osoi_liq_prev(site_hydr%nlevsoi_hyd) = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - & + dtime*bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) + + else + !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) + bc_out(s)%qflx_soil2root_sisl(j) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:)) * & + site_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & + site_hydr%recruit_w_uptake(j) + + ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & + ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + + ! Save the amount of liquid soil water known to the model after root uptake + ! This calculation also assumes that 1mm of water is 1kg + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j) + + end if + + enddo !site_hydr%nlevsoi_hyd + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks totalrootuptake = 0.0_r8 totalqtop_dt = 0.0_r8 cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ccohort=>cpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - !totalrootuptake = totalrootuptake + ccohort_hydr%rootuptake* ccohort%n/AREA - totalqtop_dt= totalqtop_dt+ ccohort_hydr%qtop_dt* ccohort%n/AREA - ccohort => ccohort%shorter - enddo !cohort - cpatch => cpatch%younger + do while (associated(cpatch)) + ccohort=>cpatch%tallest + do while(associated(ccohort)) + ccohort_hydr => ccohort%co_hydr + !totalrootuptake = totalrootuptake + ccohort_hydr%rootuptake* ccohort%n/AREA + totalqtop_dt= totalqtop_dt+ ccohort_hydr%qtop_dt* ccohort%n/AREA + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger enddo !patch - !remove the recruitment water uptake as it has been added to prev_h2oveg + !remove the recruitment water uptake as it has been added to prev_h2oveg totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & - site_hydr%recruit_w_uptake(:))*dtime - - total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - totalqtop_dt) - + site_hydr%recruit_w_uptake(:))*dtime + + total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - totalqtop_dt) + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e - - bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & - site_hydr%h2oveg_growturn_err - & - site_hydr%h2oveg_pheno_err-& - site_hydr%h2oveg_hydro_err - - - enddo !site - + + bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & + site_hydr%h2oveg_growturn_err - & + site_hydr%h2oveg_pheno_err-& + site_hydr%h2oveg_hydro_err + + + enddo !site + end subroutine Hydraulics_BC ! ===================================================================================== @@ -3137,109 +3036,147 @@ end subroutine Hydraulics_BC subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just died. This water is accumulated at the site level for all plants - ! that die. - ! In another routine, this pool is reduced as water vapor flux, and - ! passed to the HLM. - ! --------------------------------------------------------------------------- - use EDTypesMod , only : AREA - - ! Arguments - - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - real(r8), intent(in) :: delta_n ! Loss in number density - ! for this cohort /ha/day - - real(r8) :: delta_w !water change due to mortality Kg/m2 - ! Locals - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - - ccohort_hydr => ccohort%co_hydr - csite_hydr => csite%si_hydr - delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*delta_n/AREA - - csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w - - - csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w - - return + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just died. This water is accumulated at the site level for all plants + ! that die. + ! In another routine, this pool is reduced as water vapor flux, and + ! passed to the HLM. + ! --------------------------------------------------------------------------- + use EDTypesMod , only : AREA + + ! Arguments + + type(ed_site_type), intent(inout), target :: csite + type(ed_cohort_type) , intent(inout), target :: ccohort + real(r8), intent(in) :: delta_n ! Loss in number density + ! for this cohort /ha/day + + real(r8) :: delta_w !water change due to mortality Kg/m2 + ! Locals + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + ccohort_hydr => ccohort%co_hydr + csite_hydr => csite%si_hydr + delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*delta_n/AREA + + csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w + + + csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w + + return end subroutine AccumulateMortalityWaterStorage !-------------------------------------------------------------------------------! - + subroutine RecruitWaterStorage(nsites,sites,bc_out) - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just recruited. This water is accumulated at the site level for all plants - ! that recruit. - ! Because this water is taken from the soil in hydraulics_bc, which will not - ! be called until the next timestep, this water is subtracted out of - ! plant_stored_h2o_si to ensure HLM water balance at the beg_curr_day timestep. - ! plant_stored_h2o_si will include this water when calculated in hydraulics_bc - ! at the next timestep, when it gets pulled from the soil water. - ! --------------------------------------------------------------------------- - use EDTypesMod, only : AREA - - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s - - if( hlm_use_planthydro.eq.ifalse ) return - - do s = 1,nsites - - csite_hydr => sites(s)%si_hydr - csite_hydr%h2oveg_recruit = 0.0_r8 - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - if(ccohort_hydr%is_newly_recruited) then - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - end if - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop - - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit / AREA - - end do - - return + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just recruited. This water is accumulated at the site level for all plants + ! that recruit. + ! Because this water is taken from the soil in hydraulics_bc, which will not + ! be called until the next timestep, this water is subtracted out of + ! plant_stored_h2o_si to ensure HLM water balance at the beg_curr_day timestep. + ! plant_stored_h2o_si will include this water when calculated in hydraulics_bc + ! at the next timestep, when it gets pulled from the soil water. + ! --------------------------------------------------------------------------- + use EDTypesMod, only : AREA + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s + + if( hlm_use_planthydro.eq.ifalse ) return + + do s = 1,nsites + + csite_hydr => sites(s)%si_hydr + csite_hydr%h2oveg_recruit = 0.0_r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + if(ccohort_hydr%is_newly_recruited) then + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + end if + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop + + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit / AREA + + end do + + return end subroutine RecruitWaterStorage + + !--------------------------------------------------------------------------------------! + + subroutine GetK(K_max,FLC,K,h_diff,inode_up,inode_low) + + ! This subroutine determines the conductance of water between two nodes. + ! The nodes may be between leaves, between leaf and stem, between stems, + ! between + + + + + + + + return + end subroutine GetK + + + subroutine GetKMax() + + + + + return + end subroutine GetKMax + + + ! -------------------------------------------------------------------------------------! + - !-------------------------------------------------------------------------------! - + ! New Site-level allocated arrays + + K() ! size N-1 + Kmax() ! size N-1 + FLC() ! size N + + + + + subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, kmax_bound, & - kmax_upper, kmax_lower, kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & - th_node, flc_min_node, qtop, thresh, thresh_break, maxiter, imult, & - dtime, dth_node_outer, the_node, we_area_outer, qtop_dt, & - dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, mono_decr_Rn, & - site_hydr, bc_in) + kmax_upper, kmax_lower, kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & + th_node, flc_min_node, qtop, & + dtime, dth_node_outer, the_node, we_area_outer, qtop_dt, & + dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, & + site_hydr, bc_in) use EDTypesMod , only : AREA ! @@ -3260,13 +3197,10 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k real(r8) , intent(in) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] real(r8) , intent(in) :: flc_min_node(:) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics) [-] real(r8) , intent(in) :: qtop ! evaporative flux from canopy [kgh2o indiv-1 s-1] - integer , intent(in) :: maxiter ! maximum iterations for timestep reduction [-] - integer , intent(in) :: imult ! iteration index multiplier [-] real(r8) , intent(in) :: thresh ! threshold for water balance error (warning only) [mm h2o] real(r8) , intent(in) :: thresh_break ! threshold for water balance error (stop model) [mm h2o] real(r8) , intent(in) :: dtime ! timestep size [s] real(r8) , intent(in) :: small_theta_num ! avoids theta values equalling thr or ths [m3 m-3] - logical , intent(in) :: mono_decr_Rn ! flag indicating whether Rn is monotonically decreasing ! Inout Arguments real(r8) , intent(inout) :: th_node(:) ! volumetric water in water storage compartments [m3 m-3] @@ -3280,7 +3214,7 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k real(r8) , intent(out) :: sapflow real(r8) , intent(out) :: rootuptake - + type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions @@ -3308,7 +3242,7 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k real(r8) :: dflcdpsi_node(n_hypool_tot) ! derivative of fractional loss of conductivity wrt psi [MPa-1] real(r8) :: k_bound( n_hypool_tot) ! lower boundary hydraulic conductance of compartments [kg s-1 MPa-1] real(r8) :: q_bound( n_hypool_tot) ! lower boundary flux rate [kg s-1] - real(r8) :: hdiff_bound( n_hypool_tot) ! total water potential difference across lower boundary [MPa-1] + real(r8) :: hdiff_bound( n_hypool_tot) ! total water potential difference across lower boundary [MPa] real(r8) :: dhdiffdpsi0( n_hypool_tot) ! derivative of total water potential difference wrt psi above [-] real(r8) :: dhdiffdpsi1( n_hypool_tot) ! derivative of total water potential difference wrt psi below [-] real(r8) :: dkbounddpsi0( n_hypool_tot) ! derivative of lower boundary conductance wrt psi above [kg s-1 MPa-2] @@ -3343,7 +3277,15 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k integer :: supsub_flag = 0 integer :: max_l !location of maximum water storage in the array type(ed_cohort_hydr_type), pointer :: ccohort_hydr - !---------------------------------------------------------------------- + + ! Constants governing solution convergence + integer,parameter :: maxiter = 5 ! maximum iterations for timestep reduction [-] + integer,parameter :: imult = 3 ! iteration index multiplier [-] + real(r8), parameter :: thresh = 1.e-7_r8 ! threshold for water balance error (warning only) [mm h2o] + real(r8), parameter :: thresh_break = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] + + + !---------------------------------------------------------------------- ccohort_hydr => ccohort%co_hydr dth_node_outer(:) = 0._r8 @@ -3355,18 +3297,18 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k ! STORE INITIAL STATES !! in case timestep needs to be chopped in half to balance water th_node_init(:) = th_node(:) - + ! Total water mass in the plant at the beginning of this solve [kg h2o] w_tot_beg_outer = sum(th_node(:)*v_node(:))*denh2o - + ! OUTER DO-WHILE LOOP !! cuts timestep in half until all sub-timesteps (inner do-while loop) balance the water budget iterh1 = 0 do while( iterh1 == 0 .or. ((abs(we_local) > thresh .or. supsub_flag /= 0) .and. iterh1 < maxiter) ) - + dt_fac = max(imult*iterh1,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. dt_new = dtime/real(dt_fac,r8) ! This is the sub-stem length in seconds @@ -3375,24 +3317,24 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k if(iterh1 .gt. 0) then th_node(:) = th_node_init(:) end if - + ! QUANTITIES OF INTEREST qtop_dt = 0._r8 ! Water loss through transpiration, integrated up to the substep [kg] dqtopdth_dthdt = 0._r8 sapflow = 0._r8 rootuptake = 0._r8 - + ! INNER DO-WHILE LOOP !! repeats, for dt_frac times, the removal of 1/dt_fac * transpiration !! (the top boundary flux condition) !! stops and returns to outer loop if at any point the water budget !! doesn't balance, so the timestep can be chopped in half again - + iterh2 = 0 we_local = 0._r8 supsub_flag = 0 do while( iterh2 < dt_fac .and. ((abs(we_local) <= thresh .and. & - supsub_flag == 0) .or. iterh1 == (maxiter-1))) + supsub_flag == 0) .or. iterh1 == (maxiter-1))) iterh2 = iterh2 + 1 ! SET DERIVED STATE VARIABLES OVER ALL NODES @@ -3412,38 +3354,43 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k call dflcgsdpsi_from_psi(ccohort_hydr%psi_ag(1),ft, dflcgsdpsi) dflcgsdth = dflcgsdpsi * dpsidth_node(1) dqtopdflcgs = 0.1411985_r8 - + !BOC... estimated by trial-and-error: this term multiplied by the maximum value of dflcgsdth gives 150. !NEEDED: an estimate for dqtopdflcgs that accounts for variable potential evapotranspiration (efpot). - + ! SET THE DQTOPDTH_LEAF TERM if(do_dqtopdth_leaf) then dqtopdth_leaf = dqtopdflcgs * dflcgsdth -! if(mono_decr_Rn .and. ccohort_hydr%psi_ag(1) >= -0.88_r8) then -! dqtopdth_leaf = 0._r8 -! else if(ccohort_hydr%psi_ag(1) < -0.88_r8) then -! dqtopdth_leaf = 150._r8 -! else -! dqtopdth_leaf = 0._r8 -! end if else dqtopdth_leaf = 0._r8 end if ! SET BOUNDARY PRESSURE DIFFERENCES & CONDUCTANCES !! compute water potential differences + conductances and their derivatives wrt water potential - call boundary_hdiff_and_k((n_hypool_tot-nshell), z_node, psi_node, flc_node, dflcdpsi_node, & - kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, dhdiffdpsi0, & - dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) - + call boundary_hdiff_and_k( n_hypool_tot-nshell, & ! where the boundary occurs between root and soil (absorbing root node) + z_node, & ! elevation of all compartments [m] + psi_node, & ! water potential in compartment [Mpa] + flc_node, & ! frac loss conductivity [kg s-1 Mpa-1] + dflcdpsi_node, & ! change in FLC per change in water potential [kg s-1 Mpa-2] + kmax_bound, & ! max conductance at lower boundary of node [kg s-1 Mpa-1] + kmax_upper, & + kmax_lower, & + hdiff_bound, & ! out: difference in potential across nodes [Mpa] + k_bound, & + dhdiffdpsi0, & + dhdiffdpsi1, & + dkbounddpsi0, & + dkbounddpsi1, & + kmax_bound_aroot_soil1, & + kmax_bound_aroot_soil2) + ! SET BOUNDARY FLUX TERMS !! compute flux terms and their derivatives wrt water content q_bound(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) dqbounddpsi0(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * dhdiffdpsi0(1:n_hypool_tot-1) - & - dkbounddpsi0(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) + dkbounddpsi0(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) dqbounddpsi1(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * dhdiffdpsi1(1:n_hypool_tot-1) - & - dkbounddpsi1(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) + dkbounddpsi1(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) dqbounddth0(1:n_hypool_tot-1) = dqbounddpsi0(1:n_hypool_tot-1) * dpsidth_node(1:n_hypool_tot-1) dqbounddth1(1:n_hypool_tot-1) = dqbounddpsi1(1:n_hypool_tot-1) * dpsidth_node(2:n_hypool_tot) @@ -3467,10 +3414,10 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k !! intermediate nodes (plant and soil) do k=2,(n_hypool_tot-1) - rmx(k) = q_bound(k-1) - q_bound(k) - amx(k) = -1._r8 * dqbounddth0(k-1) - bmx(k) = dqbounddth0(k) - dqbounddth1(k-1) - v_node(k)*denh2o/dt_new - cmx(k) = dqbounddth1(k) + rmx(k) = q_bound(k-1) - q_bound(k) + amx(k) = -1._r8 * dqbounddth0(k-1) + bmx(k) = dqbounddth0(k) - dqbounddth1(k-1) - v_node(k)*denh2o/dt_new + cmx(k) = dqbounddth1(k) enddo !! outermost rhizosphere shell @@ -3479,96 +3426,98 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k amx(k) = -1._r8 * dqbounddth0(k-1) bmx(k) = -dqbounddth1(k-1) - v_node(k)*denh2o/dt_new cmx(k) = 0._r8 - + ! SOLVE TRIDIAGONAL MATRIX call Hydraulics_Tridiagonal(amx, bmx, cmx, rmx, dth_node_inner) - - ! CATCH NAN VALUES - catch_nan = .false. - index_nan = 999 - do k = 1, n_hypool_tot - if(isnan(dth_node_inner(k))) then - catch_nan = .true. - index_nan = k - end if - end do + + ! CATCH NAN VALUES + catch_nan = .false. + index_nan = 999 + do k = 1, n_hypool_tot + if(isnan(dth_node_inner(k))) then + catch_nan = .true. + index_nan = k + end if + end do if(catch_nan) then write(fates_log(),*)'EDPlantHydraulics returns nan at k = ', index_nan call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! CATCH SUPERSATURATED OR SUB-RESIDUAL WATER CONTENTS - ccohort_hydr%supsub_flag = 0._r8 - supsub_flag = 0 + end if + + ! CATCH SUPERSATURATED OR SUB-RESIDUAL WATER CONTENTS + ccohort_hydr%supsub_flag = 0._r8 + supsub_flag = 0 do k=1,n_hypool_tot th_prev = th_node(k) - dth_prev = dth_node_inner(k) - if( (th_node(k)+dth_node_inner(k)) > (ths_node(k)-small_theta_num)) then - supsub_flag = k - supsub_flag_node(k) = 1._r8 - ccohort_hydr%supsub_flag = real(k) - th_node(k) = ths_node(k)-small_theta_num - else if((th_node(k)+dth_node_inner(k)) < (thr_node(k)+small_theta_num)) then - supsub_flag = -k - ccohort_hydr%supsub_flag = -real(k) - supsub_flag_node(k) = -1._r8 - th_node(k) = thr_node(k)+small_theta_num - else + dth_prev = dth_node_inner(k) + if( (th_node(k)+dth_node_inner(k)) > (ths_node(k)-small_theta_num)) then + supsub_flag = k + supsub_flag_node(k) = 1._r8 + ccohort_hydr%supsub_flag = real(k) + th_node(k) = ths_node(k)-small_theta_num + else if((th_node(k)+dth_node_inner(k)) < (thr_node(k)+small_theta_num)) then + supsub_flag = -k + ccohort_hydr%supsub_flag = -real(k) + supsub_flag_node(k) = -1._r8 + th_node(k) = thr_node(k)+small_theta_num + else th_node(k) = th_node(k)+dth_node_inner(k) - end if - dth_node_inner(k) = th_node(k) - th_prev - the_node(k) = dth_node_inner(k) - dth_prev + end if + dth_node_inner(k) = th_node(k) - th_prev + the_node(k) = dth_node_inner(k) - dth_prev enddo - - ! QUANTITIES OF INTEREST - qtop_dt = qtop_dt + & - qtop*dt_new - dqtopdth_dthdt = dqtopdth_dthdt + & - dqtopdth_leaf*dth_node_inner(1)*dt_new - sapflow = sapflow + & - (q_bound(index_stem) + & - dqbounddth0(index_stem)*dth_node_inner(index_stem) + & - dqbounddth1(index_stem)*dth_node_inner(index_stem+1))*dt_new - rootuptake = rootuptake + & - (q_bound(index_aroot) + & - dqbounddth0(index_aroot)*dth_node_inner(index_aroot) + & - dqbounddth1(index_aroot)*dth_node_inner(index_aroot+1))*dt_new - - ! UPDATE ERROR TERM + + ! QUANTITIES OF INTEREST + qtop_dt = qtop_dt + & + qtop*dt_new + dqtopdth_dthdt = dqtopdth_dthdt + & + dqtopdth_leaf*dth_node_inner(1)*dt_new + sapflow = sapflow + & + (q_bound(index_stem) + & + dqbounddth0(index_stem)*dth_node_inner(index_stem) + & + dqbounddth1(index_stem)*dth_node_inner(index_stem+1))*dt_new + rootuptake = rootuptake + & + (q_bound(index_aroot) + & + dqbounddth0(index_aroot)*dth_node_inner(index_aroot) + & + dqbounddth1(index_aroot)*dth_node_inner(index_aroot+1))*dt_new + + ! UPDATE ERROR TERM w_tot_end_inner = sum(th_node(:)*v_node(:))*denh2o - dw_tot_inner = w_tot_end_inner - w_tot_beg_inner + dw_tot_inner = w_tot_end_inner - w_tot_beg_inner + we_tot_inner = dw_tot_inner/dt_new + (qtop + dqtopdth_leaf*dth_node_inner(1)) - we_area_inner = we_tot_inner/(cCohort%c_area / cCohort%n) - we_vol_inner = we_tot_inner/sum(v_node(:)) + + we_area_inner = we_tot_inner/(cCohort%c_area / cCohort%n) + we_vol_inner = we_tot_inner/sum(v_node(:)) ! we_vol_inner ! different water balance metrics can be chosen here (with an appropriate corresponding thresh) - we_local = we_tot_inner*cCohort%n/AREA - + we_local = we_tot_inner*cCohort%n/AREA + end do ! loop over sub-timesteps iterh1 = iterh1 + 1 - + end do ! loop to get a timestep divisor that balances water - + ccohort_hydr%iterh1 = real(iterh1) ccohort_hydr%iterh2 = real(iterh2) ! WATER BALANCE ERROR-HANDLING if ( (abs(we_local) > thresh) .and. debug) then write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds threshold of ',& - thresh + thresh else if (abs(we_local) > thresh_break) then write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', thresh_break write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & - ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o root_water = (sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' @@ -3579,35 +3528,35 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! TOTAL NET WATER BALANCE AND ERROR ADJUST HACK w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then - if(debug) then + if(debug) then write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' - endif - !dump the error water to the bin with largest water storage - max_l = maxloc(th_node(:)*v_node(:),dim=1) - th_node(max_l) = th_node(max_l)- & - we_tot_outer/(v_node(max_l)*denh2o) - th_node(max_l) = min (th_node(max_l),& - ths_node(max_l)-small_theta_num) - th_node(max_l) = max(th_node(max_l),& - thr_node(max_l)+small_theta_num) - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual + endif + !dump the error water to the bin with largest water storage + max_l = maxloc(th_node(:)*v_node(:),dim=1) + th_node(max_l) = th_node(max_l)- & + we_tot_outer/(v_node(max_l)*denh2o) + th_node(max_l) = min (th_node(max_l),& + ths_node(max_l)-small_theta_num) + th_node(max_l) = max(th_node(max_l),& + thr_node(max_l)+small_theta_num) + w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg + dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep + we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep + we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual end if dth_node_outer(:) = th_node(:) - th_node_init(:) - end subroutine Hydraulics_1DSolve + end subroutine Hydraulics_1DSolve !-------------------------------------------------------------------------------! - subroutine Hydraulics_Tridiagonal(a, b, c, r, u) + subroutine Hydraulics_Tridiagonal(a, b, c, r, u) ! ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 ! @@ -3632,22 +3581,22 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) u(k) = r(k) / bet else gam(k) = c(k-1) / bet - bet = b(k) - a(k) * gam(k) - u(k) = (r(k) - a(k)*u(k-1)) / bet + bet = b(k) - a(k) * gam(k) + u(k) = (r(k) - a(k)*u(k-1)) / bet end if enddo - + do k=n_hypool_tot-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) + u(k) = u(k) - gam(k+1) * u(k+1) enddo - - end subroutine Hydraulics_Tridiagonal + + end subroutine Hydraulics_Tridiagonal !-------------------------------------------------------------------------------! subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdpsi_node, & - kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, & - dhdiffdpsi0, dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + kmax_bound, kmax_upper, kmax_lower, hdiff_bound, k_bound, & + dhdiffdpsi0, dhdiffdpsi1, dkbounddpsi0, dkbounddpsi1, & + kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) ! ! !ARGUMENTS integer , intent(in) :: k_arootsoil ! index of node where the boundary occurs between root and soil @@ -3658,7 +3607,7 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps real(r8) , intent(in) :: kmax_bound(:) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] real(r8) , intent(in) :: kmax_upper(:) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] real(r8) , intent(in) :: kmax_lower(:) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - real(r8) , intent(out) :: hdiff_bound(:) ! total water potential difference across lower boundary [MPa-1] + real(r8) , intent(out) :: hdiff_bound(:) ! total water potential difference across lower boundary [MPa] real(r8) , intent(out) :: k_bound(:) ! lower boundary hydraulic conductance of compartments [kg s-1 MPa-1] real(r8) , intent(out) :: dhdiffdpsi0(:) ! derivative of total water potential difference wrt psi above [-] real(r8) , intent(out) :: dhdiffdpsi1(:) ! derivative of total water potential difference wrt psi below [-] @@ -3676,33 +3625,35 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps !---------------------------------------------------------------------- do k = 1, (size(z_node)-1) - hdiff_bound(k) = 1.e-6_r8*denh2o*grav*(z_node(k) - z_node(k+1)) + & - (psi_node(k) - psi_node(k+1)) + hdiff_bound(k) = 1.e-6_r8*denh2o*grav_earth*(z_node(k) - z_node(k+1)) + & + (psi_node(k) - psi_node(k+1)) if(do_kbound_upstream) then ! absorbing root-1st rhizosphere shell boundary. ! Comprised of two distinct conductance terms each with distinct water potentials if(k == (k_arootsoil)) then - + k_bound_aroot_soil1 = kmax_bound_aroot_soil1 * flc_node(k) k_bound_aroot_soil2 = kmax_bound_aroot_soil2 * flc_node(k+1) + k_bound(k) = 1._r8/(1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) + dkbounddpsi0(k) = ((k_bound(k)/k_bound_aroot_soil1)**2._r8) * & - kmax_bound_aroot_soil1*dflcdpsi_node(k) + kmax_bound_aroot_soil1*dflcdpsi_node(k) dkbounddpsi1(k) = ((k_bound(k)/k_bound_aroot_soil2)**2._r8) * & - kmax_bound_aroot_soil2*dflcdpsi_node(k+1) + kmax_bound_aroot_soil2*dflcdpsi_node(k+1) else ! examine direction of water flow; use the upstream node's k for the boundary k. ! (as suggested by Ethan Coon, LANL) if(hdiff_bound(k) < 0._r8) then - k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere - dkbounddpsi0(k) = 0._r8 - dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) + k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere + dkbounddpsi0(k) = 0._r8 + dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) else - k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil - dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) - dkbounddpsi1(k) = 0._r8 + k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil + dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) + dkbounddpsi1(k) = 0._r8 end if end if else @@ -3719,9 +3670,9 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps k_bound(k) = 0._r8 dkbounddpsi0(k) = 0._r8 dkbounddpsi1(k) = 0._r8 - + end subroutine boundary_hdiff_and_k - + !-------------------------------------------------------------------------------! subroutine flc_gs_from_psi(cc_p, lwp ) ! @@ -3734,994 +3685,994 @@ subroutine flc_gs_from_psi(cc_p, lwp ) real(r8) , intent(in) :: lwp !leaf water potential (MPa) ! ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: cCohort - integer :: FT - !---------------------------------------------------------------------- - - cCohort => cc_p - FT = cCohort%pft - ccohort%co_hydr%btran(:) = & - (1._r8 + (lwp/EDPftvarcon_inst%hydr_p50_gs(ft))**EDPftvarcon_inst%hydr_avuln_gs(ft))**(-1._r8) - - end subroutine flc_gs_from_psi - - !-------------------------------------------------------------------------------! - subroutine dflcgsdpsi_from_psi(lwp, ft, dflcgsdpsi) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: lwp ! leaf water potential (MPa) - integer , intent(in) :: ft ! leaf pft - real(r8) , intent(out) :: dflcgsdpsi ! fractional loss of conductivity [-] - - !---------------------------------------------------------------------- - - associate(& - avuln_gs => EDPftvarcon_inst%hydr_avuln_gs, & ! Input: [real(r8) (:) ] stomatal PLC curve: shape parameter [-] - p50_gs => EDPftvarcon_inst%hydr_p50_gs & ! Input: [real(r8) (:) ] stomatal PLC curve: water potential at 50% loss of gs,max [Pa] - ) - - dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(FT))**avuln_gs(FT))**(-2._r8) * & - avuln_gs(FT)/p50_gs(FT)*(lwp/p50_gs(FT))**(avuln_gs(FT)-1._r8) - - end associate - - end subroutine dflcgsdpsi_from_psi - - !-------------------------------------------------------------------------------! - subroutine flc_from_psi(ft, pm, psi_node, flc_node, site_hydr, bc_in ) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: psi_node ! water potential [MPa] - real(r8) , intent(out) :: flc_node ! fractional loss of conductivity [-] - type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions - - ! - ! !LOCAL VARIABLES: - - !---------------------------------------------------------------------- - - associate(& - avuln => EDPftvarcon_inst%hydr_avuln_node , & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] - p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] - ) - - if(pm <= 4) then - flc_node = 1._r8/(1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm)) - else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) -! call unsatkVG_flc_from_psi(psi_node, & -! site_hydr%alpha_VG(1), & -! site_hydr%n_VG(1), & -! site_hydr%m_VG(1), & -! site_hydr%l_VG(1), & -! flc_node) - case (campbell) - call unsatkCampbell_flc_from_psi(psi_node, & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & ! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa - bc_in%bsw_sisl(1), & - flc_node) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate - - end subroutine flc_from_psi - - !-------------------------------------------------------------------------------! - subroutine dflcdpsi_from_psi(ft, pm, psi_node, dflcdpsi_node, site_hydr, bc_in ) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: psi_node ! water potential [MPa] - real(r8) , intent(out) :: dflcdpsi_node ! fractional loss of conductivity [-] - type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions - - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - avuln => EDPftvarcon_inst%hydr_avuln_node, & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] - p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] - ) - - if(pm <= 4) then - dflcdpsi_node = -1._r8 * (1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm))**(-2._r8) * & - avuln(ft,pm)/p50(ft,pm)*(psi_node/p50(ft,pm))**(avuln(ft,pm)-1._r8) - else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !call unsatkVG_dflcdpsi_from_psi(psi_node, & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! dflcdpsi_node) - case (campbell) - call unsatkCampbell_dflcdpsi_from_psi(psi_node, & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(1), & - dflcdpsi_node) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate - - end subroutine dflcdpsi_from_psi - - !-------------------------------------------------------------------------------! - subroutine th_from_psi(ft, pm, psi_node, th_node, site_hydr, bc_in) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to volumetric water contents - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: psi_node ! water potential [MPa] - real(r8) , intent(out) :: th_node ! water content [m3 m-3] - type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions - - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound of initial estimate [m3 m-3] - real(r8) :: upper ! upper bound of initial estimate [m3 m-3] - real(r8) :: xtol ! error tolerance for x-variable [m3 m-3] - real(r8) :: ytol ! error tolerance for y-variable [MPa] - real(r8) :: satfrac ! soil saturation fraction [0-1] - real(r8) :: psi_check - - !---------------------------------------------------------------------- - - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction - ) - - if(pm <= 4) then - - lower = thetas(ft,pm)*(resid(ft,pm) + 0.0001_r8)/cap_corr(pm) - upper = thetas(ft,pm) - xtol = 1.e-16_r8 - ytol = 1.e-8_r8 - call bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) - call psi_from_th(ft, pm, th_node, psi_check ) - - if(psi_check > -1.e-8_r8) then - write(fates_log(),*)'bisect_pv returned positive value for water potential at pm = ', char(pm) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - - else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) -! call swcVG_satfrac_from_psi(psi_node, & -! site_hydr%alpha_VG(1), & -! site_hydr%n_VG(1), & -! site_hydr%m_VG(1), & -! site_hydr%l_VG(1), & -! satfrac) -! call swcVG_th_from_satfrac(satfrac, & -! bc_in%watsat_sisl(1), & -! bc_in%watres_sisl(1), & -! th_node) - case (campbell) - - call swcCampbell_satfrac_from_psi(psi_node, & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(1), & - satfrac) - call swcCampbell_th_from_satfrac(satfrac, & - bc_in%watsat_sisl(1), & - th_node) - case default - write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate - - end subroutine th_from_psi - - !-------------------------------------------------------------------------------! - subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. - ! An analytical solution is not possible because quadratic smoothing functions - ! are used to remove discontinuities in the PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(inout) :: lower ! lower bound of estimate [m3 m-3] - real(r8) , intent(inout) :: upper ! upper bound of estimate [m3 m-3] - real(r8) , intent(in) :: xtol ! error tolerance for x-variable [m3 m-3] - real(r8) , intent(in) :: ytol ! error tolerance for y-variable [MPa] - real(r8) , intent(in) :: psi_node ! water potential [MPa] - real(r8) , intent(out) :: th_node ! water content [m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: x_new ! new estimate for x in bisection routine - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - integer :: nitr ! number of iterations - !---------------------------------------------------------------------- - if(psi_node > 0.0_r8) then - write(fates_log(),*)'Error: psi_note become positive,& - psi_node=',psi_node - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - call psi_from_th(ft, pm, lower, y_lo) - call psi_from_th(ft, pm, upper, y_hi) - f_lo = y_lo - psi_node - f_hi = y_hi - psi_node - chg = upper - lower - nitr = 0 - do while(abs(chg) .gt. xtol .and. nitr < 100) - x_new = 0.5_r8*(lower + upper) - call psi_from_th(ft, pm, x_new, y_new) - f_new = y_new - psi_node - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - nitr = nitr + 1 - end do - - if(nitr .eq. 100)then - write(fates_log(),*)'Warning: number of iteraction reaches 100 for bisect_pv' - endif - - th_node = x_new - - end subroutine bisect_pv - - !-------------------------------------------------------------------------------! - subroutine psi_from_th(ft, pm, th_node, psi_node, site_hydr, bc_in) - ! - ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) - ! at a given water content (th) - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: th_node ! water content [m3 m-3] - real(r8) , intent(out) :: psi_node ! water potential [MPa] - type(ed_site_hydr_type), optional, intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type), optional, intent(in) :: bc_in ! FATES boundary conditions - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac ! saturation fraction [0-1] - !---------------------------------------------------------------------- - - if(pm <= 4) then ! plant - - call tq2(ft, pm, th_node*cap_corr(pm), psi_node) - - else if(pm == 5) then ! soil - -!! NOTE. FIX: The below sidesteps the problem of averaging potentially variable soil hydraulic properties with depth -!! and simply assigns the bulk soil (bucket) approximation of hydraulic properties as equal to the top soil layer. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) -! call swcVG_psi_from_th(th_node, & -! bc_in%watsat_sisl(1), & -! bc_in%watres_sisl(1), & -! site_hydr%alpha_VG(1), & -! site_hydr%n_VG(1), & -! site_hydr%m_VG(1), & -! site_hydr%l_VG(1), & -! psi_node) - case (campbell) - call swcCampbell_psi_from_th(th_node, & - bc_in%watsat_sisl(1), & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(1), & - psi_node) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - end if - - end subroutine psi_from_th - - !-------------------------------------------------------------------------------! - subroutine dpsidth_from_th(ft, pm, th_node, y, site_hydr, bc_in) - ! - ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) - ! at a given water content (th) - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: th_node ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - type(ed_site_hydr_type), optional,intent(inout) :: site_hydr - type(bc_in_type), optional,intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - - real(r8) :: satfrac ! saturation fraction [0-1] - !---------------------------------------------------------------------- - - if(pm <= 4) then ! plant - call dtq2dth(ft, pm, th_node*cap_corr(pm), y) - else if(pm == 5) then ! soil - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !call swcVG_dpsidth_from_th(th_node, & - ! bc_in%watsat_sisl(1), & - ! bc_in%watres_sisl(1), & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! y) - case (campbell) - call swcCampbell_dpsidth_from_th(th_node, & - bc_in%watsat_sisl(1), & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav*1.e-9_r8, & - bc_in%bsw_sisl(1), & - y) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end subroutine dpsidth_from_th - - !-------------------------------------------------------------------------------! - subroutine tq2(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq2 ! returned y (psi) value from bq2() - real(r8) :: y_cq2 ! returned y (psi) value from cq2() - real(r8) :: beta2=0.99_r8 ! smoothing factor - !---------------------------------------------------------------------- - - call bq2(ft, pm, x, y_bq2) - call cq2(ft, pm, x, y_cq2) - y = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2*beta2) - - end subroutine tq2 - - !-------------------------------------------------------------------------------! - subroutine dtq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq2 ! returned y (psi) value from bq2() - real(r8) :: y_cq2 ! returned y (psi) value from cq2() - real(r8) :: dydth_bq2 ! returned derivative from dbq2dth() - real(r8) :: dydth_cq2 ! returned derivative from dcq2dth() - real(r8) :: beta2=0.99_r8 ! smoothing factor - !---------------------------------------------------------------------- - - call bq2(ft, pm, x, y_bq2) - call cq2(ft, pm, x, y_cq2) - call dbq2dth(ft, pm, x, dydth_bq2) - call dcq2dth(ft, pm, x, dydth_cq2) - y = 1._r8/(2._r8*beta2)*(-dydth_bq2 + 0.5_r8*((y_bq2*y_bq2 - 4._r8*beta2*y_cq2)**(-0.5_r8)) * & - (2._r8*y_bq2*dydth_bq2 - 4._r8*beta2*dydth_cq2)) - - end subroutine dtq2dth - - !-------------------------------------------------------------------------------! - subroutine bq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = -1._r8*(y_tq1 + y_cavitation) - - end subroutine bq2 - - !-------------------------------------------------------------------------------! - subroutine dbq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = -1._r8*(dydth_tq1 + dcavdth) - - end subroutine dbq2dth - - !-------------------------------------------------------------------------------! - subroutine cq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = y_tq1*y_cavitation - - end subroutine cq2 - - !-------------------------------------------------------------------------------! - subroutine dcq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq2() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = y_tq1*dcavdth + dydth_tq1*y_cavitation - - end subroutine dcq2dth - - !-------------------------------------------------------------------------------! - subroutine tq1(ft, pm, x, y) - ! - ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or - ! does a smoothing function for capillary-to-elastic region of the plant PV - ! curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call elasticPV(ft, pm, x, y_elastic) - y = y_elastic - else if(pm <= 4) then ! sapwood has a capillary region - call bq1(ft, pm, x, y_bq1) - call cq1(ft, pm, x, y_cq1) - y = (-y_bq1 - sqrt(y_bq1*y_bq1 - 4._r8*beta1*y_cq1))/(2*beta1) - end if !porous media - - end subroutine tq1 - - !-------------------------------------------------------------------------------! - subroutine dtq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of tq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() - real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call delasticPVdth(ft, pm, x, delasticdth) - y = delasticdth - else if(pm <= 4) then ! sapwood has a capillary region - call bq1(ft, pm, x, y_bq1) - call cq1(ft, pm, x, y_cq1) - call dbq1dth(ft, pm, x, dydth_bq1) - call dcq1dth(ft, pm, x, dydth_cq1) - y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & - (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) - end if - - end subroutine dtq1dth - - !-------------------------------------------------------------------------------! - subroutine bq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = -1._r8*(y_capillary + y_elastic) - - end subroutine bq1 - - !-------------------------------------------------------------------------------! - subroutine dbq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of bq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = -1._r8*(delasticdth + dcapdth) - - end subroutine dbq1dth - - !-------------------------------------------------------------------------------! - subroutine cq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = y_capillary*y_elastic - - end subroutine cq1 - - !-------------------------------------------------------------------------------! - subroutine dcq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = y_elastic*dcapdth + delasticdth*y_capillary - - end subroutine dcq1dth - - !-------------------------------------------------------------------------------! - subroutine cavitationPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - !---------------------------------------------------------------------- - - call solutepsi(ft, pm, x, y_solute) - y = y_solute - - end subroutine cavitationPV - - !-------------------------------------------------------------------------------! - subroutine dcavitationPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - y = dsoldth - - end subroutine dcavitationPVdth - - !-------------------------------------------------------------------------------! - subroutine elasticPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() - !---------------------------------------------------------------------- - - call solutepsi(ft, pm, x, y_solute) - call pressurepsi(ft, pm, x, y_pressure) - y = y_solute + y_pressure - - end subroutine elasticPV - - !-------------------------------------------------------------------------------! - subroutine delasticPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of elasticPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - real(r8) :: dpressdth ! returned derivative from dpressurepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - call dpressurepsidth(ft, pm, x, dpressdth) - y = dsoldth + dpressdth - - end subroutine delasticPVdth - - !-------------------------------------------------------------------------------! - subroutine solutepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes solute water potential (negative) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => EDPftvarcon_inst%hydr_pinot_node, & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) - - y = pinot(ft,pm)*thetas(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - (x - thetas(ft,pm)*resid(ft,pm)) - - end associate - - end subroutine solutepsi - - !-------------------------------------------------------------------------------! - subroutine dsolutepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of solutepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) - - y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - ((x - thetas(ft,pm)*resid(ft,pm))**2._r8) - - end associate - - end subroutine dsolutepsidth - - !-------------------------------------------------------------------------------! - subroutine pressurepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes pressure water potential (positive) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] - ) - - y = epsil(ft,pm) * (x - thetas(ft,pm)*rwcft(pm)) / & - (thetas(ft,pm)*(rwcft(pm)-resid(ft,pm))) - pinot(ft,pm) - - end associate - - end subroutine pressurepsi - - !-------------------------------------------------------------------------------! - subroutine dpressurepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] - ) - - y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) - - end associate - - end subroutine dpressurepsidth - - !-------------------------------------------------------------------------------! - subroutine capillaryPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the capillary region of the plant - ! PV curve (sapwood only) - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: cCohort + integer :: FT !---------------------------------------------------------------------- - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) - - y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x - - end associate + cCohort => cc_p + FT = cCohort%pft + ccohort%co_hydr%btran(:) = & + (1._r8 + (lwp/EDPftvarcon_inst%hydr_p50_gs(ft))**EDPftvarcon_inst%hydr_avuln_gs(ft))**(-1._r8) + + end subroutine flc_gs_from_psi - end subroutine capillaryPV - !-------------------------------------------------------------------------------! - subroutine dcapillaryPVdth(ft, pm, x, y) + subroutine dflcgsdpsi_from_psi(lwp, ft, dflcgsdpsi) ! - ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to a fractional loss of conductivity ! ! !USES: ! ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: + real(r8) , intent(in) :: lwp ! leaf water potential (MPa) + integer , intent(in) :: ft ! leaf pft + real(r8) , intent(out) :: dflcgsdpsi ! fractional loss of conductivity [-] + !---------------------------------------------------------------------- associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + avuln_gs => EDPftvarcon_inst%hydr_avuln_gs, & ! Input: [real(r8) (:) ] stomatal PLC curve: shape parameter [-] + p50_gs => EDPftvarcon_inst%hydr_p50_gs & ! Input: [real(r8) (:) ] stomatal PLC curve: water potential at 50% loss of gs,max [Pa] ) - - y = cap_slp(pm)/thetas(ft,pm) - - end associate - end subroutine dcapillaryPVdth - - !-------------------------------------------------------------------------------! - subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) + dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(FT))**avuln_gs(FT))**(-2._r8) * & + avuln_gs(FT)/p50_gs(FT)*(lwp/p50_gs(FT))**(avuln_gs(FT)-1._r8) + + end associate + +end subroutine dflcgsdpsi_from_psi + +!-------------------------------------------------------------------------------! +subroutine flc_from_psi(ft, pm, psi_node, flc_node, site_hydr, bc_in ) + ! + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to a fractional loss of conductivity + + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8) , intent(out) :: flc_node ! fractional loss of conductivity [-] + type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure + type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions + + ! + ! !LOCAL VARIABLES: + + !---------------------------------------------------------------------- + + associate(& + avuln => EDPftvarcon_inst%hydr_avuln_node , & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] + p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] + ) + + if(pm <= 4) then + flc_node = 1._r8/(1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm)) + else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call unsatkVG_flc_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! flc_node) + case (campbell) + call unsatkCampbell_flc_from_psi(psi_node, & + (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & ! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa + bc_in%bsw_sisl(1), & + flc_node) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end if + +end associate + +end subroutine flc_from_psi + +!-------------------------------------------------------------------------------! +subroutine dflcdpsi_from_psi(ft, pm, psi_node, dflcdpsi_node, site_hydr, bc_in ) + ! + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to a fractional loss of conductivity + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: psi_node ! water potential [MPa] +real(r8) , intent(out) :: dflcdpsi_node ! fractional loss of conductivity [-] +type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure +type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions + +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& + avuln => EDPftvarcon_inst%hydr_avuln_node, & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] + p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] + ) + +if(pm <= 4) then + dflcdpsi_node = -1._r8 * (1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm))**(-2._r8) * & + avuln(ft,pm)/p50(ft,pm)*(psi_node/p50(ft,pm))**(avuln(ft,pm)-1._r8) +else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + !call unsatkVG_dflcdpsi_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! dflcdpsi_node) + case (campbell) + call unsatkCampbell_dflcdpsi_from_psi(psi_node, & + (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(1), & + dflcdpsi_node) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select +end if + +end associate + +end subroutine dflcdpsi_from_psi + +!-------------------------------------------------------------------------------! +subroutine th_from_psi(ft, pm, psi_node, th_node, site_hydr, bc_in) + ! + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to volumetric water contents + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: psi_node ! water potential [MPa] +real(r8) , intent(out) :: th_node ! water content [m3 m-3] +type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure +type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions + +! +! !LOCAL VARIABLES: +real(r8) :: lower ! lower bound of initial estimate [m3 m-3] +real(r8) :: upper ! upper bound of initial estimate [m3 m-3] +real(r8) :: xtol ! error tolerance for x-variable [m3 m-3] +real(r8) :: ytol ! error tolerance for y-variable [MPa] +real(r8) :: satfrac ! soil saturation fraction [0-1] +real(r8) :: psi_check + +!---------------------------------------------------------------------- + +associate(& + thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content + resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction + ) + +if(pm <= 4) then + + lower = thetas(ft,pm)*(resid(ft,pm) + 0.0001_r8)/cap_corr(pm) + upper = thetas(ft,pm) + xtol = 1.e-16_r8 + ytol = 1.e-8_r8 + call bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) + call psi_from_th(ft, pm, th_node, psi_check ) + + if(psi_check > -1.e-8_r8) then + write(fates_log(),*)'bisect_pv returned positive value for water potential at pm = ', char(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + +else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_satfrac_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! satfrac) + ! call swcVG_th_from_satfrac(satfrac, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! th_node) + case (campbell) + + call swcCampbell_satfrac_from_psi(psi_node, & + (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(1), & + satfrac) + call swcCampbell_th_from_satfrac(satfrac, & + bc_in%watsat_sisl(1), & + th_node) + case default + write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select +end if + +end associate + +end subroutine th_from_psi + +!-------------------------------------------------------------------------------! +subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. + ! An analytical solution is not possible because quadratic smoothing functions + ! are used to remove discontinuities in the PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(inout) :: lower ! lower bound of estimate [m3 m-3] +real(r8) , intent(inout) :: upper ! upper bound of estimate [m3 m-3] +real(r8) , intent(in) :: xtol ! error tolerance for x-variable [m3 m-3] +real(r8) , intent(in) :: ytol ! error tolerance for y-variable [MPa] +real(r8) , intent(in) :: psi_node ! water potential [MPa] +real(r8) , intent(out) :: th_node ! water content [m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: x_new ! new estimate for x in bisection routine +real(r8) :: y_lo ! corresponding y value at lower +real(r8) :: f_lo ! y difference between lower bound guess and target y +real(r8) :: y_hi ! corresponding y value at upper +real(r8) :: f_hi ! y difference between upper bound guess and target y +real(r8) :: y_new ! corresponding y value at x.new +real(r8) :: f_new ! y difference between new y guess at x.new and target y +real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) +integer :: nitr ! number of iterations +!---------------------------------------------------------------------- +if(psi_node > 0.0_r8) then +write(fates_log(),*)'Error: psi_note become positive,& + psi_node=',psi_node +call endrun(msg=errMsg(sourcefile, __LINE__)) +endif +call psi_from_th(ft, pm, lower, y_lo) +call psi_from_th(ft, pm, upper, y_hi) +f_lo = y_lo - psi_node +f_hi = y_hi - psi_node +chg = upper - lower +nitr = 0 +do while(abs(chg) .gt. xtol .and. nitr < 100) +x_new = 0.5_r8*(lower + upper) +call psi_from_th(ft, pm, x_new, y_new) +f_new = y_new - psi_node +if(abs(f_new) .le. ytol) then + EXIT +end if +if((f_lo * f_new) .lt. 0._r8) upper = x_new +if((f_hi * f_new) .lt. 0._r8) lower = x_new +chg = upper - lower +nitr = nitr + 1 +end do + +if(nitr .eq. 100)then +write(fates_log(),*)'Warning: number of iteraction reaches 100 for bisect_pv' +endif + +th_node = x_new + +end subroutine bisect_pv + +!-------------------------------------------------------------------------------! +subroutine psi_from_th(ft, pm, th_node, psi_node, site_hydr, bc_in) + ! + ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) + ! at a given water content (th) + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: th_node ! water content [m3 m-3] +real(r8) , intent(out) :: psi_node ! water potential [MPa] +type(ed_site_hydr_type), optional, intent(inout),target :: site_hydr ! ED site_hydr structure +type(bc_in_type), optional, intent(in) :: bc_in ! FATES boundary conditions +! +! !LOCAL VARIABLES: +real(r8) :: satfrac ! saturation fraction [0-1] +!---------------------------------------------------------------------- + +if(pm <= 4) then ! plant + +call tq2(ft, pm, th_node*cap_corr(pm), psi_node) + +else if(pm == 5) then ! soil + + !! NOTE. FIX: The below sidesteps the problem of averaging potentially variable soil hydraulic properties with depth + !! and simply assigns the bulk soil (bucket) approximation of hydraulic properties as equal to the top soil layer. +select case (iswc) +case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_psi_from_th(th_node, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! psi_node) +case (campbell) + call swcCampbell_psi_from_th(th_node, & + bc_in%watsat_sisl(1), & + (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(1), & + psi_node) +case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) +end select + +end if + +end subroutine psi_from_th + +!-------------------------------------------------------------------------------! +subroutine dpsidth_from_th(ft, pm, th_node, y, site_hydr, bc_in) + ! + ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) + ! at a given water content (th) + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: th_node ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +type(ed_site_hydr_type), optional,intent(inout) :: site_hydr +type(bc_in_type), optional,intent(in) :: bc_in +! +! !LOCAL VARIABLES: + +real(r8) :: satfrac ! saturation fraction [0-1] +!---------------------------------------------------------------------- + +if(pm <= 4) then ! plant +call dtq2dth(ft, pm, th_node*cap_corr(pm), y) +else if(pm == 5) then ! soil +select case (iswc) +case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + !call swcVG_dpsidth_from_th(th_node, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! y) +case (campbell) + call swcCampbell_dpsidth_from_th(th_node, & + bc_in%watsat_sisl(1), & + (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & + bc_in%bsw_sisl(1), & + y) +case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) +end select +end if + +end subroutine dpsidth_from_th + +!-------------------------------------------------------------------------------! +subroutine tq2(ft, pm, x, y) + ! + ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the + ! plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_bq2 ! returned y (psi) value from bq2() +real(r8) :: y_cq2 ! returned y (psi) value from cq2() +real(r8) :: beta2=0.99_r8 ! smoothing factor +!---------------------------------------------------------------------- + +call bq2(ft, pm, x, y_bq2) +call cq2(ft, pm, x, y_cq2) +y = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2*beta2) + +end subroutine tq2 + +!-------------------------------------------------------------------------------! +subroutine dtq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the + ! plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: y_bq2 ! returned y (psi) value from bq2() +real(r8) :: y_cq2 ! returned y (psi) value from cq2() +real(r8) :: dydth_bq2 ! returned derivative from dbq2dth() +real(r8) :: dydth_cq2 ! returned derivative from dcq2dth() +real(r8) :: beta2=0.99_r8 ! smoothing factor +!---------------------------------------------------------------------- + +call bq2(ft, pm, x, y_bq2) +call cq2(ft, pm, x, y_cq2) +call dbq2dth(ft, pm, x, dydth_bq2) +call dcq2dth(ft, pm, x, dydth_cq2) +y = 1._r8/(2._r8*beta2)*(-dydth_bq2 + 0.5_r8*((y_bq2*y_bq2 - 4._r8*beta2*y_cq2)**(-0.5_r8)) * & + (2._r8*y_bq2*dydth_bq2 - 4._r8*beta2*dydth_cq2)) + +end subroutine dtq2dth + +!-------------------------------------------------------------------------------! +subroutine bq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_tq1 ! returned y (psi) value from tq1() +real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() +!---------------------------------------------------------------------- + +call tq1(ft, pm, x, y_tq1) +call cavitationPV(ft, pm, x, y_cavitation) +y = -1._r8*(y_tq1 + y_cavitation) + +end subroutine bq2 + +!-------------------------------------------------------------------------------! +subroutine dbq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() +real(r8) :: dcavdth ! returned derivative from dcavitationdth() +!---------------------------------------------------------------------- + +call dtq1dth(ft, pm, x, dydth_tq1) +call dcavitationPVdth(ft, pm, x, dcavdth) +y = -1._r8*(dydth_tq1 + dcavdth) + +end subroutine dbq2dth + +!-------------------------------------------------------------------------------! +subroutine cq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_tq1 ! returned y (psi) value from tq1() +real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() +!---------------------------------------------------------------------- + +call tq1(ft, pm, x, y_tq1) +call cavitationPV(ft, pm, x, y_cavitation) +y = y_tq1*y_cavitation + +end subroutine cq2 + +!-------------------------------------------------------------------------------! +subroutine dcq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq2() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: y_tq1 ! returned y (psi) value from tq1() +real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() +real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() +real(r8) :: dcavdth ! returned derivative from dcavitationdth() +!---------------------------------------------------------------------- + +call tq1(ft, pm, x, y_tq1) +call cavitationPV(ft, pm, x, y_cavitation) +call dtq1dth(ft, pm, x, dydth_tq1) +call dcavitationPVdth(ft, pm, x, dcavdth) +y = y_tq1*dcavdth + dydth_tq1*y_cavitation + +end subroutine dcq2dth + +!-------------------------------------------------------------------------------! +subroutine tq1(ft, pm, x, y) + ! + ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or + ! does a smoothing function for capillary-to-elastic region of the plant PV + ! curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_bq1 ! returned y (psi) value from bq1() +real(r8) :: y_cq1 ! returned y (psi) value from cq1() +real(r8) :: y_elastic ! returned y (psi) value from elasticPV() +real(r8) :: beta1=0.80_r8 ! smoothing factor +!---------------------------------------------------------------------- + +if(pm == 1) then ! leaves have no capillary region in their PV curves +call elasticPV(ft, pm, x, y_elastic) +y = y_elastic +else if(pm <= 4) then ! sapwood has a capillary region +call bq1(ft, pm, x, y_bq1) +call cq1(ft, pm, x, y_cq1) +y = (-y_bq1 - sqrt(y_bq1*y_bq1 - 4._r8*beta1*y_cq1))/(2*beta1) +end if !porous media + +end subroutine tq1 + +!-------------------------------------------------------------------------------! +subroutine dtq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of tq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: y_bq1 ! returned y (psi) value from bq1() +real(r8) :: y_cq1 ! returned y (psi) value from cq1() +real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() +real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() +real(r8) :: delasticdth ! returned derivative from delasticPVdth() +real(r8) :: beta1=0.80_r8 ! smoothing factor +!---------------------------------------------------------------------- + +if(pm == 1) then ! leaves have no capillary region in their PV curves +call delasticPVdth(ft, pm, x, delasticdth) +y = delasticdth +else if(pm <= 4) then ! sapwood has a capillary region +call bq1(ft, pm, x, y_bq1) +call cq1(ft, pm, x, y_cq1) +call dbq1dth(ft, pm, x, dydth_bq1) +call dcq1dth(ft, pm, x, dydth_cq1) +y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & + (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) +end if + +end subroutine dtq1dth + +!-------------------------------------------------------------------------------! +subroutine bq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() +real(r8) :: y_elastic ! returned y (psi) value from elasticPV() +!---------------------------------------------------------------------- + +call capillaryPV(ft, pm, x, y_capillary) +call elasticPV(ft, pm, x, y_elastic) +y = -1._r8*(y_capillary + y_elastic) + +end subroutine bq1 + +!-------------------------------------------------------------------------------! +subroutine dbq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of bq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() +real(r8) :: delasticdth ! returned derivative from delasticPVdth() +!---------------------------------------------------------------------- + +call dcapillaryPVdth(ft, pm, x, dcapdth) +call delasticPVdth(ft, pm, x, delasticdth) +y = -1._r8*(delasticdth + dcapdth) + +end subroutine dbq1dth + +!-------------------------------------------------------------------------------! +subroutine cq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() +real(r8) :: y_elastic ! returned y (psi) value from elasticPV() +!---------------------------------------------------------------------- + +call capillaryPV(ft, pm, x, y_capillary) +call elasticPV(ft, pm, x, y_elastic) +y = y_capillary*y_elastic + +end subroutine cq1 + +!-------------------------------------------------------------------------------! +subroutine dcq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() +real(r8) :: y_elastic ! returned y (psi) value from elasticPV() +real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() +real(r8) :: delasticdth ! returned derivative from delasticPVdth() +!---------------------------------------------------------------------- + +call capillaryPV(ft, pm, x, y_capillary) +call elasticPV(ft, pm, x, y_elastic) +call dcapillaryPVdth(ft, pm, x, dcapdth) +call delasticPVdth(ft, pm, x, delasticdth) +y = y_elastic*dcapdth + delasticdth*y_capillary + +end subroutine dcq1dth + +!-------------------------------------------------------------------------------! +subroutine cavitationPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_solute ! returned y (psi) value from solutepsi() +!---------------------------------------------------------------------- + +call solutepsi(ft, pm, x, y_solute) +y = y_solute + +end subroutine cavitationPV + +!-------------------------------------------------------------------------------! +subroutine dcavitationPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: dsoldth ! returned derivative from dsolutepsidth() +!---------------------------------------------------------------------- + +call dsolutepsidth(ft, pm, x, dsoldth) +y = dsoldth + +end subroutine dcavitationPVdth + +!-------------------------------------------------------------------------------! +subroutine elasticPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: y_solute ! returned y (psi) value from solutepsi() +real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() +!---------------------------------------------------------------------- + +call solutepsi(ft, pm, x, y_solute) +call pressurepsi(ft, pm, x, y_pressure) +y = y_solute + y_pressure + +end subroutine elasticPV + +!-------------------------------------------------------------------------------! +subroutine delasticPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of elasticPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +real(r8) :: dsoldth ! returned derivative from dsolutepsidth() +real(r8) :: dpressdth ! returned derivative from dpressurepsidth() +!---------------------------------------------------------------------- + +call dsolutepsidth(ft, pm, x, dsoldth) +call dpressurepsidth(ft, pm, x, dpressdth) +y = dsoldth + dpressdth + +end subroutine delasticPVdth + +!-------------------------------------------------------------------------------! +subroutine solutepsi(ft, pm, x, y) + ! + ! !DESCRIPTION: computes solute water potential (negative) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& + pinot => EDPftvarcon_inst%hydr_pinot_node, & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] + thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + ) + +y = pinot(ft,pm)*thetas(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & + (x - thetas(ft,pm)*resid(ft,pm)) + +end associate + +end subroutine solutepsi + +!-------------------------------------------------------------------------------! +subroutine dsolutepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of solutepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& +pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] +thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] +resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] +) + +y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & +((x - thetas(ft,pm)*resid(ft,pm))**2._r8) + +end associate + +end subroutine dsolutepsidth + +!-------------------------------------------------------------------------------! +subroutine pressurepsi(ft, pm, x, y) + ! + ! !DESCRIPTION: computes pressure water potential (positive) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& +pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] +thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] +resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] +epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] +) + +y = epsil(ft,pm) * (x - thetas(ft,pm)*rwcft(pm)) / & +(thetas(ft,pm)*(rwcft(pm)-resid(ft,pm))) - pinot(ft,pm) + +end associate + +end subroutine pressurepsi + +!-------------------------------------------------------------------------------! +subroutine dpressurepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& +thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] +resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] +epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] +) + +y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) + +end associate + +end subroutine dpressurepsidth + +!-------------------------------------------------------------------------------! +subroutine capillaryPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the capillary region of the plant + ! PV curve (sapwood only) + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! water potential [MPa] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& +thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] +) + +y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x + +end associate + +end subroutine capillaryPV + +!-------------------------------------------------------------------------------! +subroutine dcapillaryPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS +integer , intent(in) :: ft ! PFT index +integer , intent(in) :: pm ! porous media index +real(r8) , intent(in) :: x ! water content [m3 m-3] +real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] +! +! !LOCAL VARIABLES: +!---------------------------------------------------------------------- + +associate(& +thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] +) + +y = cap_slp(pm)/thetas(ft,pm) + +end associate + +end subroutine dcapillaryPVdth + +!-------------------------------------------------------------------------------! +subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4730,20 +4681,20 @@ subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(out) :: satfrac !saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] +real(r8), intent(out) :: satfrac !saturation fraction [0-1] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - satfrac = (th - watres)/(watsat - watres) +satfrac = (th - watres)/(watsat - watres) - end subroutine swcVG_satfrac_from_th +end subroutine swcVG_satfrac_from_th - !-------------------------------------------------------------------------------! - subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) +!-------------------------------------------------------------------------------! +subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4751,19 +4702,19 @@ subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) ! !USES !ARGUMENTS: - real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(out) :: satfrac !saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(out) :: satfrac !saturation fraction [0-1] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - satfrac = th/watsat +satfrac = th/watsat - end subroutine swcCampbell_satfrac_from_th +end subroutine swcCampbell_satfrac_from_th - !-------------------------------------------------------------------------------! - subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) +!-------------------------------------------------------------------------------! +subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4772,26 +4723,26 @@ subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcVG_satfrac_from_th(th, watsat, watres, satfrac) - call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) - - end subroutine swcVG_psi_from_th - - !-------------------------------------------------------------------------------! - subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) +real(r8), intent(in) :: th !volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: psi !soil matric potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: satfrac !saturation fraction [0-1] +!------------------------------------------------------------------------------ + +call swcVG_satfrac_from_th(th, watsat, watres, satfrac) +call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) + +end subroutine swcVG_psi_from_th + +!-------------------------------------------------------------------------------! +subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4800,23 +4751,23 @@ subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) - - end subroutine swcCampbell_psi_from_th - - !-------------------------------------------------------------------------------! - subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) +real(r8), intent(in) :: th !volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: psisat !air entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: psi !soil matric potential [MPa] +! +! !LOCAL VARIABLES: +real(r8) :: satfrac !saturation fraction [0-1] +!------------------------------------------------------------------------------ + +call swcCampbell_satfrac_from_th(th, watsat, satfrac) +call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) + +end subroutine swcCampbell_psi_from_th + +!-------------------------------------------------------------------------------! +subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4825,22 +4776,22 @@ subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) - - end subroutine swcVG_psi_from_satfrac - - !-------------------------------------------------------------------------------! - subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: psi !soil matric potential [MPa] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ + +psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) + +end subroutine swcVG_psi_from_satfrac + +!-------------------------------------------------------------------------------! +subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4849,20 +4800,20 @@ subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: psisat !air entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: psi !soil matric potential [MPa] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - psi = psisat*(satfrac**(-B)) +psi = psisat*(satfrac**(-B)) - end subroutine swcCampbell_psi_from_satfrac +end subroutine swcCampbell_psi_from_satfrac - !-------------------------------------------------------------------------------! - subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) +!-------------------------------------------------------------------------------! +subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4871,20 +4822,20 @@ subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] +real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - th = watres + satfrac*(watsat - watres) +th = watres + satfrac*(watsat - watres) - end subroutine swcVG_th_from_satfrac +end subroutine swcVG_th_from_satfrac - !-------------------------------------------------------------------------------! - subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) +!-------------------------------------------------------------------------------! +subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4893,19 +4844,19 @@ subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - th = satfrac*watsat +th = satfrac*watsat - end subroutine swcCampbell_th_from_satfrac +end subroutine swcCampbell_th_from_satfrac - !----------------------------------------------------------------------- - subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) +!----------------------------------------------------------------------- +subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4914,22 +4865,22 @@ subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m - - end subroutine swcVG_satfrac_from_psi - - !----------------------------------------------------------------------- - subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ + +satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m + +end subroutine swcVG_satfrac_from_psi + +!----------------------------------------------------------------------- +subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4938,20 +4889,20 @@ subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: psisat !air-entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] +! +! !LOCAL VARIABLES: +!------------------------------------------------------------------------------ - satfrac = (psi/psisat)**(-1.0_r8/B) +satfrac = (psi/psisat)**(-1.0_r8/B) - end subroutine swcCampbell_satfrac_from_psi +end subroutine swcCampbell_satfrac_from_psi - !----------------------------------------------------------------------- - subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) +!----------------------------------------------------------------------- +subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -4961,26 +4912,26 @@ subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcVG_satfrac_from_th(th, watsat, watres, satfrac) - call swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) - - end subroutine swcVG_dpsidth_from_th - - !----------------------------------------------------------------------- - subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) +real(r8), intent(in) :: th !volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] +! +! !LOCAL VARIABLES: +real(r8) :: satfrac !saturation fraction [0-1] +!------------------------------------------------------------------------------ + +call swcVG_satfrac_from_th(th, watsat, watres, satfrac) +call swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) + +end subroutine swcVG_dpsidth_from_th + +!----------------------------------------------------------------------- +subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -4990,23 +4941,23 @@ subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) - - end subroutine swcCampbell_dpsidth_from_th - - !----------------------------------------------------------------------- - subroutine swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) +real(r8), intent(in) :: th !volumetric water content [m3 m-3] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: psisat !air entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] +! +! !LOCAL VARIABLES: +real(r8) :: satfrac !saturation fraction [0-1] +!------------------------------------------------------------------------------ + +call swcCampbell_satfrac_from_th(th, watsat, satfrac) +call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) + +end subroutine swcCampbell_dpsidth_from_th + +!----------------------------------------------------------------------- +subroutine swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -5016,32 +4967,32 @@ subroutine swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, d !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: temp0 !temporary - real(r8) :: temp1 !temporary - real(r8) :: temp2 !temporary - real(r8) :: temp3 !temporary - !------------------------------------------------------------------------------ - - temp0 = 1._r8/(m*n*alpha*(watsat-watres)) - temp1 = satfrac**(-1._r8/m) - 1._r8 - temp2 = temp1**(1._r8/n - 1._r8) - temp3 = satfrac**(-1._r8/m - 1._r8) - dpsidth = temp0*temp2*temp3 - - end subroutine swcVG_dpsidth_from_satfrac - - !----------------------------------------------------------------------- - subroutine swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] +! +! !LOCAL VARIABLES: +real(r8) :: temp0 !temporary +real(r8) :: temp1 !temporary +real(r8) :: temp2 !temporary +real(r8) :: temp3 !temporary +!------------------------------------------------------------------------------ + +temp0 = 1._r8/(m*n*alpha*(watsat-watres)) +temp1 = satfrac**(-1._r8/m) - 1._r8 +temp2 = temp1**(1._r8/n - 1._r8) +temp3 = satfrac**(-1._r8/m - 1._r8) +dpsidth = temp0*temp2*temp3 + +end subroutine swcVG_dpsidth_from_satfrac + +!----------------------------------------------------------------------- +subroutine swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -5051,19 +5002,19 @@ subroutine swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - !------------------------------------------------------------------------------ +real(r8), intent(in) :: satfrac !saturation fraction [0-1] +real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] +real(r8), intent(in) :: psisat !air-entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] +!------------------------------------------------------------------------------ - dpsidth = psisat*(-B)/watsat*(satfrac)**(-B-1._r8) +dpsidth = psisat*(-B)/watsat*(satfrac)**(-B-1._r8) - end subroutine swcCampbell_dpsidth_from_satfrac +end subroutine swcCampbell_dpsidth_from_satfrac - !----------------------------------------------------------------------- - subroutine unsatkVG_flc_from_psi(psi, alpha, n, m, l, flc) +!----------------------------------------------------------------------- +subroutine unsatkVG_flc_from_psi(psi, alpha, n, m, l, flc) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -5073,33 +5024,33 @@ subroutine unsatkVG_flc_from_psi(psi, alpha, n, m, l, flc) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] - ! - ! !LOCAL VARIABLES: - real(r8) :: temp !temporary - real(r8) :: fac1a !temporary - real(r8) :: fac1b !temporary - real(r8) :: fac1 !temporary - real(r8) :: fac2 !temporary - !------------------------------------------------------------------------------ - - temp = ( alpha*abs(psi) ) ** (n) - fac1a = ( alpha*abs(psi) ) ** (n-1._r8) - fac1b = ( 1._r8 + temp ) ** (-1._r8*m) - fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) - fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) - - flc = fac1 * fac2 - - end subroutine unsatkVG_flc_from_psi - - !----------------------------------------------------------------------- - subroutine unsatkCampbell_flc_from_psi(psi, psisat, B, flc) +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] +! +! !LOCAL VARIABLES: +real(r8) :: temp !temporary +real(r8) :: fac1a !temporary +real(r8) :: fac1b !temporary +real(r8) :: fac1 !temporary +real(r8) :: fac2 !temporary +!------------------------------------------------------------------------------ + +temp = ( alpha*abs(psi) ) ** (n) +fac1a = ( alpha*abs(psi) ) ** (n-1._r8) +fac1b = ( 1._r8 + temp ) ** (-1._r8*m) +fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) +fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) + +flc = fac1 * fac2 + +end subroutine unsatkVG_flc_from_psi + +!----------------------------------------------------------------------- +subroutine unsatkCampbell_flc_from_psi(psi, psisat, B, flc) ! ! DESCRIPTION ! Campbell (1974) soil water characteristic (retention) curve @@ -5109,18 +5060,18 @@ subroutine unsatkCampbell_flc_from_psi(psi, psisat, B, flc) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] - !------------------------------------------------------------------------------ - - flc = (psi/psisat)**(-2._r8-3._r8/B) +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: psisat !air-entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] +!------------------------------------------------------------------------------ + +flc = (psi/psisat)**(-2._r8-3._r8/B) - end subroutine unsatkCampbell_flc_from_psi +end subroutine unsatkCampbell_flc_from_psi - !----------------------------------------------------------------------- - subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) +!----------------------------------------------------------------------- +subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -5130,44 +5081,44 @@ subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] - ! - ! !LOCAL VARIABLES: - real(r8) :: temp !temporary - real(r8) :: fac1a !temporary - real(r8) :: fac1b !temporary - real(r8) :: fac1 !temporary - real(r8) :: fac2 !temporary - real(r8) :: dtemp !temporary - real(r8) :: dfac1adpsi !temporary - real(r8) :: dfac1bdpsi !temporary - real(r8) :: dfac1dpsi !temporary - real(r8) :: dfac2dpsi !temporary - !------------------------------------------------------------------------------ - - temp = ( alpha*abs(psi) ) ** (n) - fac1a = ( alpha*abs(psi) ) ** (n-1._r8) - fac1b = ( 1._r8 + temp ) ** (-1._r8*m) - fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) - fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) - - dtemp = n * alpha * ( alpha*abs(psi) ) ** (n-1._r8) - dfac1adpsi = ( n-1._r8 ) * alpha * ( alpha*abs(psi) ) ** (n-2._r8) - dfac1bdpsi = ( -1._r8 ) * m * dtemp * ( 1._r8 + temp ) ** (-1._r8*m - 1._r8) - dfac1dpsi = ( 2._r8 ) * ( 1._r8 - fac1a*fac1b ) * ( -1._r8*dfac1bdpsi*fac1a - dfac1adpsi*fac1b ) - dfac2dpsi = ( -0.5_r8 ) * m * dtemp * (1._r8 + temp)**(-0.5_r8*m-1._r8) - - dflcdpsi = ( -1._r8 ) * ( dfac2dpsi*fac1 + dfac1dpsi*fac2 ) ! BOC... mult by -1 because unsatk eqn is based on abs(psi) - - end subroutine unsatkVG_dflcdpsi_from_psi - - !----------------------------------------------------------------------- - subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] +real(r8), intent(in) :: n !pore-size distribution index [-] +real(r8), intent(in) :: m != 1 - 1/n_VG [-] +real(r8), intent(in) :: l !pore tortuosity parameter [-] +real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] +! +! !LOCAL VARIABLES: +real(r8) :: temp !temporary +real(r8) :: fac1a !temporary +real(r8) :: fac1b !temporary +real(r8) :: fac1 !temporary +real(r8) :: fac2 !temporary +real(r8) :: dtemp !temporary +real(r8) :: dfac1adpsi !temporary +real(r8) :: dfac1bdpsi !temporary +real(r8) :: dfac1dpsi !temporary +real(r8) :: dfac2dpsi !temporary +!------------------------------------------------------------------------------ + +temp = ( alpha*abs(psi) ) ** (n) +fac1a = ( alpha*abs(psi) ) ** (n-1._r8) +fac1b = ( 1._r8 + temp ) ** (-1._r8*m) +fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) +fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) + +dtemp = n * alpha * ( alpha*abs(psi) ) ** (n-1._r8) +dfac1adpsi = ( n-1._r8 ) * alpha * ( alpha*abs(psi) ) ** (n-2._r8) +dfac1bdpsi = ( -1._r8 ) * m * dtemp * ( 1._r8 + temp ) ** (-1._r8*m - 1._r8) +dfac1dpsi = ( 2._r8 ) * ( 1._r8 - fac1a*fac1b ) * ( -1._r8*dfac1bdpsi*fac1a - dfac1adpsi*fac1b ) +dfac2dpsi = ( -0.5_r8 ) * m * dtemp * (1._r8 + temp)**(-0.5_r8*m-1._r8) + +dflcdpsi = ( -1._r8 ) * ( dfac2dpsi*fac1 + dfac1dpsi*fac2 ) ! BOC... mult by -1 because unsatk eqn is based on abs(psi) + +end subroutine unsatkVG_dflcdpsi_from_psi + +!----------------------------------------------------------------------- +subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -5177,195 +5128,195 @@ subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] - !------------------------------------------------------------------------------ - - dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) +real(r8), intent(in) :: psi !soil matric potential [MPa] +real(r8), intent(in) :: psisat !air-entry pressure [MPa] +real(r8), intent(in) :: B !shape parameter [-] +real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] +!------------------------------------------------------------------------------ - end subroutine unsatkCampbell_dflcdpsi_from_psi +dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) +end subroutine unsatkCampbell_dflcdpsi_from_psi - ! ===================================================================================== - ! Utility Functions - ! ===================================================================================== - subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants - real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] - real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] - real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] - real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] - real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] - real(r8) , intent(out) :: x_new ! soil depth [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound x estimate [m] - real(r8) :: upper ! upper bound x estimate [m] - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - !---------------------------------------------------------------------- - - lower = lower_init - upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr - chg = upper - lower - do while(abs(chg) .gt. xtol) - x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - end do - end subroutine bisect_rootfr - ! ===================================================================================== - - function zeng2001_crootfr(a, b, z) result(crootfr) - - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - ! - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) - - return +! Utility Functions +! ===================================================================================== - end function zeng2001_crootfr +subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS +real(r8) , intent(in) :: a, b ! pft root distribution constants +real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] +real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] +real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] +real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] +real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] +real(r8) , intent(out) :: x_new ! soil depth [m] +! +! !LOCAL VARIABLES: +real(r8) :: lower ! lower bound x estimate [m] +real(r8) :: upper ! upper bound x estimate [m] +real(r8) :: y_lo ! corresponding y value at lower +real(r8) :: f_lo ! y difference between lower bound guess and target y +real(r8) :: y_hi ! corresponding y value at upper +real(r8) :: f_hi ! y difference between upper bound guess and target y +real(r8) :: y_new ! corresponding y value at x.new +real(r8) :: f_new ! y difference between new y guess at x.new and target y +real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) +!---------------------------------------------------------------------- + +lower = lower_init +upper = upper_init +f_lo = zeng2001_crootfr(a, b, lower) - crootfr +f_hi = zeng2001_crootfr(a, b, upper) - crootfr +chg = upper - lower +do while(abs(chg) .gt. xtol) +x_new = 0.5_r8*(lower + upper) +f_new = zeng2001_crootfr(a, b, x_new) - crootfr +if(abs(f_new) .le. ytol) then +EXIT +end if +if((f_lo * f_new) .lt. 0._r8) upper = x_new +if((f_hi * f_new) .lt. 0._r8) lower = x_new +chg = upper - lower +end do +end subroutine bisect_rootfr - ! ===================================================================================== +! ===================================================================================== - subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: - - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot - real(r8) , intent(in) :: rs1 - real(r8) , intent(in) :: area - real(r8) , intent(in) :: dz - real(r8) , intent(out) :: r_out_shell(:) - real(r8) , intent(out) :: r_node_shell(:) - real(r8) , intent(out) :: v_shell(:) ! volume of a single rhizosphere shell - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - !----------------------------------------------------------------------- +function zeng2001_crootfr(a, b, z) result(crootfr) - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshell) = (pi_const*l_aroot/(area*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshell > 1) then - do k = 1,nshell-1 - r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 - enddo - end if + ! !ARGUMENTS: +real(r8) , intent(in) :: a,b ! pft parameters +real(r8) , intent(in) :: z ! soil depth (m) +! +! !RESULT +real(r8) :: crootfr ! cumulative root fraction +! +!------------------------------------------------------------------------ +crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) - ! set nodal (midpoint) radii of these shells - do k = 1,nshell - if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - ! r_node_shell(k) = 0.5_r8*(rs1 + r_out_shell(k)) - r_node_shell(k) = 0.5_r8*(r_out_shell(k)) - else - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - end if - enddo +return - ! update volumes - do k = 1,nshell - if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level - ! v_shell(k) = pi*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8) - else - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo +end function zeng2001_crootfr - end subroutine shellGeom +! ===================================================================================== - ! ===================================================================================== +subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: - function xylemtaper(p, dz) result(chi_tapnotap) + ! + ! !ARGUMENTS: +real(r8) , intent(in) :: l_aroot +real(r8) , intent(in) :: rs1 +real(r8) , intent(in) :: area +real(r8) , intent(in) :: dz +real(r8) , intent(out) :: r_out_shell(:) +real(r8) , intent(out) :: r_node_shell(:) +real(r8) , intent(out) :: v_shell(:) ! volume of a single rhizosphere shell +! +! !LOCAL VARIABLES: +integer :: k ! rhizosphere shell indicies +!----------------------------------------------------------------------- + +! update outer radii of column-level rhizosphere shells (same across patches and cohorts) +r_out_shell(nshell) = (pi_const*l_aroot/(area*dz))**(-0.5_r8) ! eqn(8) S98 +if(nshell > 1) then +do k = 1,nshell-1 +r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 +enddo +end if + +! set nodal (midpoint) radii of these shells +do k = 1,nshell +if(k == 1) then + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + ! r_node_shell(k) = 0.5_r8*(rs1 + r_out_shell(k)) +r_node_shell(k) = 0.5_r8*(r_out_shell(k)) +else +r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) +end if +enddo + +! update volumes +do k = 1,nshell +if(k == 1) then + ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level + ! v_shell(k) = pi*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) +v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8) +else +v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) +end if +enddo + +end subroutine shellGeom - ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] - real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) - real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) - ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) - ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. - ! Hydraulic trade-offs and space filling enable better predictions of vascular structure - ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. - real(r8) :: lN=0.04_r8 ! petiole length [m] - real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] - real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] - real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: num ! temporary - real(r8) :: den ! temporary - ! - ! !RESULT - real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz - ! - !------------------------------------------------------------------------ - - anotap = 7.19903e-13_r8 - bnotap = 1.326105578_r8 - if (p >= 1.0_r8) then - btap = 2.00586217_r8 - atap = 1.82513E-12_r8 - else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then - btap = 1.854812819_r8 - atap = 6.66908E-13_r8 - else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then - btap = 1.628179741_r8 - atap = 6.58345E-13_r8 - else - btap = bnotap - atap = anotap - end if +! ===================================================================================== - num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) - den = log(little_n) - big_n = num/den - 1._r8 - ktap = atap * (little_n**(big_N* btap/2._r8)) - knotap = anotap * (little_n**(big_N*bnotap/2._r8)) - chi_tapnotap = ktap / knotap +function xylemtaper(p, dz) result(chi_tapnotap) - return + ! !ARGUMENTS: +real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] +real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] +! +! !LOCAL VARIABLES: +real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) +real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) +! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) +! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. +! Hydraulic trade-offs and space filling enable better predictions of vascular structure +! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. +real(r8) :: lN=0.04_r8 ! petiole length [m] +real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] +real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] +real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: num ! temporary +real(r8) :: den ! temporary +! +! !RESULT +real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz +! +!------------------------------------------------------------------------ + +anotap = 7.19903e-13_r8 +bnotap = 1.326105578_r8 +if (p >= 1.0_r8) then +btap = 2.00586217_r8 +atap = 1.82513E-12_r8 +else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then +btap = 1.854812819_r8 +atap = 6.66908E-13_r8 +else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then +btap = 1.628179741_r8 +atap = 6.58345E-13_r8 +else +btap = bnotap +atap = anotap +end if + +num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) +den = log(little_n) +big_n = num/den - 1._r8 +ktap = atap * (little_n**(big_N* btap/2._r8)) +knotap = anotap * (little_n**(big_N*bnotap/2._r8)) +chi_tapnotap = ktap / knotap + +return + +end function xylemtaper - end function xylemtaper - end module FatesPlantHydraulicsMod diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 6720cfa0c5..ffa80ed47b 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -127,6 +127,12 @@ module FatesConstantsMod ! Gravity constant on earth [m/s] real(fates_r8), parameter, public :: grav_earth = 9.8_fates_r8 + ! Megapascals to pascals + real(fates_r8), parameter, public :: pa_per_mpa = 1.e6_fates_r8 + + ! Pascals to megapascals + real(fates_r8), parameter, public :: mpa_per_pa = 1.e-6_fates_r8 + ! For numerical inquiry real(fates_r8), parameter, public :: fates_huge = huge(g_per_kg) From 816ee579ea96147e2f38ada98254eb0e681073ed Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 12 Aug 2019 15:32:23 -0700 Subject: [PATCH 004/114] hydro stuff, this is just a scratch pad at this point --- biogeophys/FatesHydroSolversMod.F90 | 244 +++++++++++++++++++++++++ biogeophys/FatesPlantHydraulicsMod.F90 | 75 ++++---- main/FatesHydraulicsMemMod.F90 | 40 ++-- 3 files changed, 297 insertions(+), 62 deletions(-) create mode 100644 biogeophys/FatesHydroSolversMod.F90 diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 new file mode 100644 index 0000000000..fe7f7e5809 --- /dev/null +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -0,0 +1,244 @@ +module FatesHydroSolversMod + + + +contains + + + + + subroutine HydraulicsMatrixSolvePHS( ) + + + + + + + + + end subroutine HydraulicsMatrixSolvePHS + + subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node, & + hdiff_bound,k_bound,dhdiffdpsi0,dhdiffdpsi1,dkbounddpsi0,dkbounddpsi1) + + ! ------------------------------------------------------------------------------------------ + ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and + ! the list need not be across the whole path from stomata to the last rhizosphere shell, but + ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. + ! ------------------------------------------------------------------------------------------ + + + ! !ARGUMENTS + type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr + type(ed_site_hydr_type), intent(in),target :: site_hydr + integer , intent(in) :: jpaths(:) ! The path indices that are to be calculated + integer , intent(in) :: ilayer ! soil layer index of interest + real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] + real(r8) , intent(in) :: dflcdpsi_node(:) ! derivative of fractional loss of conductivity wrt psi [MPa-1] + real(r8) , intent(out) :: hdiff_bound(:) ! total water potential difference across lower boundary [MPa] + real(r8) , intent(out) :: k_bound(:) ! lower boundary hydraulic conductance of compartments [kg s-1 MPa-1] + real(r8) , intent(out) :: dhdiffdpsi0(:) ! derivative of total water potential difference wrt psi above [-] + real(r8) , intent(out) :: dhdiffdpsi1(:) ! derivative of total water potential difference wrt psi below [-] + real(r8) , intent(out) :: dkbounddpsi0(:) ! derivative of lower boundary conductance wrt psi above [kg s-1 MPa-2] + real(r8) , intent(out) :: dkbounddpsi1(:) ! derivative of lower boundary conductance wrt psi below [kg s-1 MPa-2] + + + ! !LOCAL VARIABLES: + integer :: inode_up ! node index closest to atmosphere for the path of interest + integer :: inode_lo ! node index further from atmosphere for path of interest + integer :: jpath ! path index + real(r8) :: k_bound_aroot_soil1 ! radial conductance of absorbing roots [kg s-1 MPa-1] + real(r8) :: k_bound_aroot_soil2 ! conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] + real(r8) :: k_lower ! conductance node k to lower boundary [kg s-1 MPa-1] + real(r8) :: k_upper ! conductance node k+1 to upper boundary [kg s-1 MPa-1] + !---------------------------------------------------------------------- + + do j=1,size(jpaths,1) + + jpath=jpaths(j) + + inode_up = jpath + inode_lo = jpath+1 + + if(inode_up < n_hypool_ag+n_hypool_troot+1) then + ! Path is between compartments within the plant + ! (leaves,stems,transporting roots and absorbing root) + + znode_up = cohort_hydr%z_node(inode_up) + znode_lo = cohort_hydr%z_node(inode_lo) + psinode_up = psi_node(inode_up) + psinode_lo = psi_node(inode_lo) + kmax_up = + kmax_lo = + kmax_surf = 1.e20_r8 ! There are no surface conductances + + elseif(inode_up == n_hpool_ag+n_hypool_troot+1) then + ! Path is between the absorbing root and the 1st + ! rhizosphere shell compartment + + znode_up = bc_in(s)%z_sisl(ilayer) + znode_lo = bc_in(s)%z_sisl(ilayer) + psinode_up = psi_node(inode_up) + psinode_lo = psi_node(inode_lo) + + kmax_surf = + kmax_up=kmax_bound + kmax_lo=site_hydr%kmax_bound_shell(ilayer,inode_lo) + + else + ! Path is between rhizosphere shells + + znode_up = bc_in(s)%z_sisl(ilayer) + znode_lo = bc_in(s)%z_sisl(ilayer) + psinode_up = psi_node(inode_up) + psinode_lo = psi_node(inode_lo) + + kmax_up=site_hydr%kmax_bound_shell(ilayer,inode_up) + kmax_lo=site_hydr%kmax_bound_shell(ilayer,inode_lo) + + end if + + hdiff_bound(jpath) = mpa_per_pa*denh2o*grav_earth*(znode_up-znode_lo) + (psinode_up-psinode_lo) + + + ! examine direction of water flow; use the upstream node's k for the boundary k. + ! (as suggested by Ethan Coon, LANL) + if(do_kbound_upstream) then + + if(hdiff_bound(jpath) < 0._r8) then + ! More potential in the lower node, use its fraction of conductivity loss + k_bound(jpath) = flc_node(inode_lo) / & + (1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) * flc_node(k+1) ! water moving towards atmosphere + dkdpsi0(jpath) = 0._r8 + dkdpsi1(jpath) = kmax_bound(jpath) * dflcdpsi_node(inode_lo) + + else + + + + + + + end if + end if + + + if(do_kbound_upstream) then + + ! absorbing root-1st rhizosphere shell boundary. + ! Comprised of two distinct conductance terms each with distinct water potentials + + if(k == (k_arootsoil)) then + + k_bound_aroot_soil1 = kmax_bound_aroot_soil1 * flc_node(k) + k_bound_aroot_soil2 = kmax_bound_aroot_soil2 * flc_node(k+1) + + k_bound(k) = 1._r8/(1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) + + dkbounddpsi0(k) = ((k_bound(k)/k_bound_aroot_soil1)**2._r8) * & + kmax_bound_aroot_soil1*dflcdpsi_node(k) + dkbounddpsi1(k) = ((k_bound(k)/k_bound_aroot_soil2)**2._r8) * & + kmax_bound_aroot_soil2*dflcdpsi_node(k+1) + else + ! examine direction of water flow; use the upstream node's k for the boundary k. + ! (as suggested by Ethan Coon, LANL) + if(hdiff_bound(k) < 0._r8) then + k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere + dkbounddpsi0(k) = 0._r8 + dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) + else + k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil + dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) + dkbounddpsi1(k) = 0._r8 + end if + end if + else + k_lower = kmax_lower(k) * flc_node(k) + k_upper = kmax_upper(k+1) * flc_node(k+1) + k_bound(k) = 1._r8/(1._r8/k_lower + 1._r8/k_upper) + dkbounddpsi0(k) = ((k_bound(k)/k_lower)**2._r8) * kmax_lower(k) * dflcdpsi_node(k) + dkbounddpsi1(k) = ((k_bound(k)/k_upper)**2._r8) * kmax_upper(k+1)* dflcdpsi_node(k+1) + end if + dhdiffdpsi0(k) = 1.0 + dhdiffdpsi1(k) = -1.0 + enddo + k = size(z_node) + k_bound(k) = 0._r8 + dkbounddpsi0(k) = 0._r8 + dkbounddpsi1(k) = 0._r8 + + end subroutine HDiffK1D + + + subroutine PlantKmax() + + + ! ------------------------------------------------------------------------------ + ! Part II. Set maximum (size-dependent) hydraulic conductances + ! ------------------------------------------------------------------------------ + + ! first estimate cumulative (petiole to node k) conductances + ! without taper as well as the chi taper function + + do k=n_hypool_leaf,n_hypool_ag + dz_node1_lowerk = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_lower_ag(k) + if(k < n_hypool_ag) then + dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_node_ag(k+1) + else + dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & + - ccohort_hydr%z_node_troot(1) + end if + kmax_node1_nodekplus1(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_nodekplus1 + kmax_node1_lowerk(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_lowerk + chi_node1_nodekplus1(k) = xylemtaper(taper_exponent, dz_node1_nodekplus1) + chi_node1_lowerk(k) = xylemtaper(taper_exponent, dz_node1_lowerk) + if(.not.do_kbound_upstream) then + if(crown_depth == 0._r8) then + write(fates_log(),*) 'do_kbound_upstream requires a nonzero canopy depth ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + enddo + + + ! then calculate the conductances at node boundaries as the difference of cumulative conductances + do k=n_hypool_leaf,n_hypool_ag + if(k == n_hypool_leaf) then + ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) + else + ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & + 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) + end if + + enddo + + ! finally, estimate the remaining tree conductance belowground as a residual + + kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))** (-1._r8) + + kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft)* kmax_treeag_tot + + ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) + + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot + end do + + + + + end subroutine PlantKmax + + + + + +end module FatesHydroSolversMod diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 453f1e7a1d..cd3299242c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -752,21 +752,16 @@ subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) ! Partition the total absorbing root lengths and volumes into the active soil layers ! ------------------------------------------------------------------------------ - if(nlevsoi_hyd == 1) then - ccohort_hydr%l_aroot_layer(nlevsoi_hyd) = ccohort_hydr%l_aroot_tot - ccohort_hydr%v_aroot_layer(nlevsoi_hyd) = ccohort_hydr%v_aroot_tot - else - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%l_aroot_layer(j) = rootfr*ccohort_hydr%l_aroot_tot - ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot - end do - end if + end if + ccohort_hydr%l_aroot_layer(j) = rootfr*ccohort_hydr%l_aroot_tot + ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot + end do ! ------------------------------------------------------------------------------ @@ -803,19 +798,9 @@ subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) do k=n_hypool_leaf,n_hypool_ag if(k == n_hypool_leaf) then ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) - ccohort_hydr%kmax_lower(k) = kmax_node1_lowerk(k) * chi_node1_lowerk(k) else ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - ccohort_hydr%kmax_lower(k) = ( 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) - & - 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - end if - if(k < n_hypool_ag) then - ccohort_hydr%kmax_upper(k+1) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) - else if(k == n_hypool_ag) then - ccohort_hydr%kmax_upper_troot = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_lowerk(k) *chi_node1_lowerk(k) ) ) ** (-1._r8) end if !!!!!!!!!! FOR TESTING ONLY @@ -832,24 +817,23 @@ subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) enddo ! finally, estimate the remaining tree conductance belowground as a residual - kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))**(-1._r8) - kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft) * kmax_treeag_tot + + kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))** (-1._r8) + + kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft)* kmax_treeag_tot + ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) - if(nlevsoi_hyd == 1) then - ccohort_hydr%kmax_treebg_layer(:) = ccohort_hydr%kmax_treebg_tot * & - ccohort%patchptr%rootfr_ft(ft,:) - else - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot - end do - end if + end if + ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot + end do + end if !check for bleaf @@ -961,8 +945,7 @@ subroutine KmaxInnerShell(currentSite, ccohort, hksat_soil, kmax_innershell) kmax_innershell(j) = kmax_root_surf_total ! If the nodal radius of the rhizosphere shell is > root radius - ! then we use a harmonic average of the max root surface and soil - ! conductance + ! then we add this resistance in series to the other terms else @@ -1095,9 +1078,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%z_upper_troot = ocohort_hydr%z_upper_troot ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag ncohort_hydr%z_lower_troot = ocohort_hydr%z_lower_troot - ncohort_hydr%kmax_upper = ocohort_hydr%kmax_upper ncohort_hydr%kmax_lower = ocohort_hydr%kmax_lower - ncohort_hydr%kmax_upper_troot = ocohort_hydr%kmax_upper_troot ncohort_hydr%kmax_bound = ocohort_hydr%kmax_bound ncohort_hydr%kmax_treebg_tot = ocohort_hydr%kmax_treebg_tot ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init @@ -2687,6 +2668,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kmax_lower_1l(pick_1l), hdiff_bound_1l, k_bound_1l, dhdiffdpsi0_1l, & dhdiffdpsi1_1l, dkbounddpsi0_1l, dkbounddpsi1_1l, & kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + !! upper bound limited to size()-1 b/c of zero-flux outer boundary condition kbg_layer(j) = 1._r8/sum(1._r8/k_bound_1l(1:(size(k_bound_1l)-1))) kbg_tot = kbg_tot + kbg_layer(j) @@ -3673,6 +3655,13 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps end subroutine boundary_hdiff_and_k + ! + + + + + + !-------------------------------------------------------------------------------! subroutine flc_gs_from_psi(cc_p, lwp ) ! diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 32dcc16432..fdd71be12f 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -187,33 +187,36 @@ module FatesHydraulicsMemMod type, public :: ed_cohort_hydr_type - ! BC...PLANT HYDRAULICS - "constants" that change with size. - ! Heights are referenced to soil surface (+ = above; - = below) - real(r8) :: z_node_ag(n_hypool_ag) ! nodal height of aboveground water storage compartments [m] - real(r8) :: z_node_troot(n_hypool_troot) ! nodal height of belowground water storage compartments [m] - real(r8) :: z_upper_ag(n_hypool_ag) ! upper boundary height of aboveground water storage compartments [m] - real(r8) :: z_upper_troot(n_hypool_troot) ! upper boundary height of belowground water storage compartments [m] - real(r8) :: z_lower_ag(n_hypool_ag) ! lower boundary height of aboveground water storage compartments [m] - real(r8) :: z_lower_troot(n_hypool_troot) ! lower boundary height of belowground water storage compartments [m] - real(r8) :: kmax_upper(n_hypool_ag) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] - real(r8) :: kmax_lower(n_hypool_ag) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - real(r8) :: kmax_upper_troot ! maximum hydraulic conductance from troot node to upper boundary [kg s-1 MPa-1] - real(r8) :: kmax_bound(n_hypool_ag) ! maximum hydraulic conductance at lower boundary (canopy to troot) [kg s-1 MPa-1] - real(r8) :: kmax_treebg_tot ! total belowground tree kmax (troot to surface of absorbing roots) [kg s-1 MPa-1] + ! BC...PLANT HYDRAULICS - "constants" that change with size. + ! Heights are referenced to soil surface (+ = above; - = below) + real(r8) :: z_node_ag(n_hypool_ag+n_hypool_troot) ! nodal height of non-layered water storage compartments [m] + + + ! Maximum conductances + ! ---------------------------------------------------------------------------------- + + real(r8) :: kmax_ag(n_hypool_ag) ! maximum hydraulic conductance of non-layered compartments [kg s-1 MPa-1] + real(r8),allocatable :: kmax_treebg_layer(:) ! total belowground tree kmax partitioned by soil layer [kg s-1 MPa-1] + real(r8),allocatable :: kmax_rsurf_in(:) ! Maximum hydraulic conductance of the root surface when + ! potential gradient is "in" to root + ! (kg s-1 MPa-1) + real(r8),allocatable :: kmax_rsurf_out(:) ! Maximum hydraulic conductance of the root surface when + ! potential gradient is "out" of root + ! (kg s-1 MPa-1) + + ! Compartment Volumes and lengths + real(r8) :: v_ag_init(n_hypool_ag) ! previous day's volume of aboveground water storage compartments [m3] real(r8) :: v_ag(n_hypool_ag) ! volume of aboveground water storage compartments [m3] real(r8) :: v_troot_init(n_hypool_troot) ! previous day's volume of belowground water storage compartments [m3] real(r8) :: v_troot(n_hypool_troot) ! volume of belowground water storage compartments [m3] real(r8) :: v_aroot_tot ! total volume of absorbing roots [m3] real(r8) :: l_aroot_tot ! total length of absorbing roots [m] - ! quantities indexed by soil layer - real(r8),allocatable :: z_node_aroot(:) ! nodal height of absorbing root water storage compartments [m] - real(r8),allocatable :: kmax_treebg_layer(:) ! total belowground tree kmax partitioned by soil layer [kg s-1 MPa-1] real(r8),allocatable :: v_aroot_layer_init(:) ! previous day's volume of absorbing roots by soil layer [m3] real(r8),allocatable :: v_aroot_layer(:) ! volume of absorbing roots by soil layer [m3] real(r8),allocatable :: l_aroot_layer(:) ! length of absorbing roots by soil layer [m] - real(r8),allocatable :: kmax_innershell(:) ! Maximum hydraulic conductivity of the inner rhizosphere shell (kg s-1 MPa-1) + ! BC PLANT HYDRAULICS - state variables real(r8) :: th_ag(n_hypool_ag) ! water in aboveground compartments [kgh2o/indiv] @@ -252,10 +255,9 @@ module FatesHydraulicsMemMod ! support production of new leaves. real(r8) :: errh2o_growturn_troot(n_hypool_troot) ! same as errh2o_growturn_ag but for troot pool real(r8) :: errh2o_pheno_troot(n_hypool_troot) ! same as errh2o_pheno_ag but for troot pool + ! quantities indexed by soil layer real(r8),allocatable :: th_aroot(:) ! water in absorbing roots [kgh2o/indiv] - !real(r8),allocatable :: th_aroot_prev(:) ! water in absorbing roots, prev timestep (debug) [kgh2o/indiv] - !real(r8),allocatable :: th_aroot_prev_uncorr(:) ! water in absorbing roots, prev timestep, initial guess (debug) [kgh2o/indiv] real(r8),allocatable :: psi_aroot(:) ! water potential in absorbing roots [MPa] real(r8),allocatable :: flc_aroot(:) ! fractional loss of conductivity in absorbing roots [-] real(r8),allocatable :: flc_min_aroot(:) ! min attained fractional loss of conductivity in absorbing roots From 9b813a857cc4fbc3236d6511b6e49a49ceb2ac21 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 14 Aug 2019 09:00:10 -0700 Subject: [PATCH 005/114] Finished first-pass on new routine calculating kmax, and some of the routine calculating conductance. Need to revisit stem path lengths and use the Savage fractal stuff. --- biogeophys/FatesHydroSolversMod.F90 | 368 ++++++++++++++++++------- biogeophys/FatesPlantHydraulicsMod.F90 | 148 ++-------- main/FatesHydraulicsMemMod.F90 | 56 ++-- 3 files changed, 332 insertions(+), 240 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index fe7f7e5809..534f25b825 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -5,20 +5,211 @@ module FatesHydroSolversMod contains + subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) + + ! --------------------------------------------------------------------------------- + ! + ! This routine sets the maximum conductance of all compartments in the plant, from + ! leaves, to stem, to transporting root, to the absorbing roots. + ! These properties are dependent only on the materials (conductivity) and the + ! geometry of the compartments. + ! The units of all K_max values are [kg H2O s-1 MPa-1] + ! + ! There are some different ways to represent overall conductance from node-to-node + ! throughout the hydraulic system. Universally, all can make use of a system + ! where we separate the hydraulic compartments of the nodes into the upper (closer + ! to the sky) and lower (away from the sky) portions of the compartment. It is + ! possible that due to things like xylem taper, the two portions may have different + ! conductivity, and therefore differnet conductances. + ! + ! Assumption 0. This routine calculates maximum conductivity for 1 plant. + ! Assumption 1. The compartment volumes, heights and lengths have all been + ! determined, probably called just before this routine. + ! + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! --------------------------------------------------------------------------------- + + ! Arguments + + type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr + type(ed_cohort_type),intent(in),target :: ccohort + type(ed_site_hydr_type),intent(in),target :: csite_hydr + type(bc_in_type),intent(in) :: bc_in + + + + ! Locals + integer :: k ! Compartment (node) index + integer :: k_ag ! Compartment index for above-ground indexed array + integer :: pft ! Plant Functional Type index + real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] + real(r8) :: z_lower ! Elevation of the center of lower compartment [m] + real(r8) :: z_upper ! Elevation of the center of upper compartment [m] + real(r8) :: dz_pet_upper ! Distance of upper compartment center to petiol [m] + real(r8) :: dz_pet_lower ! Distance of loewr compartment center to petiol [m] + real(r8) :: dz_lower ! Path length of the lower compartment [m] + real(r8) :: dz_upper ! Path length of the upper compartment [m] + real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] + real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways + ! [kg-1 s MPa] + real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + ! from the absorbing roots center nodes to the + ! transporting root center node + real(r8) :: rootfr ! fraction of absorbing root in each soil layer + ! assumes propotion of absorbing root is equal + ! to proportion of total root + real(r8) :: kmax_layer ! max conductance between transporting root node + ! and absorbing root node in each layer [kg s-1 MPa-1] + real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each + ! soil layer [m2] + + real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] + + + pft = ccohort%pft + + ! Get the cross-section of the plant's sapwood area [m2] + call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) + + + ! Leaf Maximum Hydraulic Conductance + ! The starting hypothesis is that there is no resistance inside the + ! leaf, between the petiole and the center of storage. To override + ! this, make provisions by changing the kmax to a not-absurdly high + ! value. It is assumed that the conductance in this default case, + ! is regulated completely by the stem conductance from the stem's + ! center of storage, to the petiole. + + ccohort_hydr%kmax_petiole_to_leaf = 1.e12_r8 + + + + + ! Stem Maximum Hydraulic Conductance + + do k=1, n_hypool_stem + + ! index for "above-ground" arrays, that contain stem and leaf + ! in one vector + k_ag = k+n_hypool_leaf + + ! Elevation of the upper and lower compartment mid-points [m] + + z_lower = 0.5_r8*(ccohort_hydr%z_node_ag(k_ag) + ccohort_hydr%z_lower_ag(k_ag)) + z_upper = 0.5_r8*(ccohort_hydr%z_node_ag(k_ag) + ccohort_hydr%z_upper_ag(k_ag)) + + ! Distance from the center of the two compartments, to the petiole [m] + + dz_pet_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_upper + dz_pet_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_lower + + + ! Path-length of the compartments [m] + + dz_upper = ccohort_hydr%z_upper_ag(k_ag) - ccohort_hydr%z_node_ag(k_ag) + dz_lower = ccohort_hydr%z_node_ag(k_ag) - ccohort_hydr%z_lower_ag(k_ag) + + + + ccohort_hydr%kmax_stem_upper(k_ag) = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, dz_pet_upper) * & + a_sapwood / dz_upper + + ccohort_hydr%kmax_stem_lower(k_ag) = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, dz_pet_lower) * & + a_sapwood / dz_lower + enddo + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) + + z_upper = 0.5*(ccohort_hydr%z_lower_ag(n_hypool_ag)+ccohort_hydr%z_node_troot) + dz_pet_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_upper + dz_upper = z_upper - ccohort_hydr%z_node_troot + + ccohort_hydr%kmax_troot_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, dz_pet_upper) * & + a_sapwood / dz_upper + + + ! The maximum conductance between the center node of the transporting root + ! compartment, and the center node of the absorbing root compartment, is calculated + ! as a residual. Specifically, we look at the total resistance the plant has in + ! the stem so far, by adding those resistances in series. + ! Then we use a parameter to specify what fraction of the resistance + ! should be below-ground between the transporting root node and the absorbing roots. + ! After that total is calculated, we then convert to a conductance, and split the + ! conductance in parallel between root layers, based on the root fraction. + ! Note* The inverse of max conductance (KMax) is minimum resistance: + + + rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & + sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & + sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & + 1._r8/kmax_troot_upper + + ! Calculate the residual resistance below ground, as a resistor + ! in series with the existing above ground + ! Invert to find below-ground kmax + kmax_bg = 1._r8/(rmin_ag * (1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) + + ! The max conductance of each layer is in parallel, therefore + ! the kmax terms of each layer, should sum to kmax_bg + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if - subroutine HydraulicsMatrixSolvePHS( ) + kmax_layer = rootfr*kmax_bg + + ! Two transport pathways, in two compartments exist in each layer. + ! These pathways are connected in serial. + ! For simplicity, we simply split the resistance between the two. + ! Mathematically, this results in simply doubling the conductance + ! and applying to both paths. Here are the two paths: + ! 1) is the path between the transporting root's center node, to + ! the boundary of the transporting root with the boundary of + ! the absorbing root (kmax_troot_lower) + ! 2) is the path between the boundary of the absorbing root and + ! transporting root, with the absorbing root's center node + ! (kmax_aroot_upper) + + ccohort_hydr%kmax_troot_lower(j) = 2.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_upper(j) = 2.0_r8 * kmax_layer + end do + ! Finally, we calculate maximum radial conductance from the root + ! surface to its center node. This transport is not a xylem transport + ! like the calculations prior to this. This transport is through the + ! exodermis, cortex, casparian strip and endodermis. The actual conductance + ! will possibly depend on the potential gradient (whether out-of the root, + ! or in-to the root). So we calculate the kmax's for both cases, + ! and save them for the final conductance calculation. + + do j=1,nlevsoi_hyd + + ! Surface area of the absorbing roots for this cohort in this layer [m2] + surfarea_aroot_layer = 2._r8 * pi_const *csite_hydr%rs1(j) * ccohort_hydr%l_aroot_layer(j) + ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] + ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer + + ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + end do + return + end subroutine UpdatePlantKMax - end subroutine HydraulicsMatrixSolvePHS - subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node, & + subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node, & hdiff_bound,k_bound,dhdiffdpsi0,dhdiffdpsi1,dkbounddpsi0,dkbounddpsi1) ! ------------------------------------------------------------------------------------------ @@ -27,7 +218,6 @@ subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. ! ------------------------------------------------------------------------------------------ - ! !ARGUMENTS type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr type(ed_site_hydr_type), intent(in),target :: site_hydr @@ -60,51 +250,95 @@ subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node inode_up = jpath inode_lo = jpath+1 - if(inode_up < n_hypool_ag+n_hypool_troot+1) then - ! Path is between compartments within the plant - ! (leaves,stems,transporting roots and absorbing root) - - znode_up = cohort_hydr%z_node(inode_up) - znode_lo = cohort_hydr%z_node(inode_lo) - psinode_up = psi_node(inode_up) - psinode_lo = psi_node(inode_lo) - kmax_up = - kmax_lo = - kmax_surf = 1.e20_r8 ! There are no surface conductances + if(inode_up == 1) then + + ! Path is between the leaf node and first stem node + + istem = 1 + + znode_up = cohort_hydr%z_node_ag(inode_up) + znode_lo = cohort_hydr%z_node_ag(inode_lo) + kmax_up = cohort_hydr%kmax_petiole_to_leaf + kmax_lo = cohort_hydr%kmax_stem_upper(1) + + elseif(inode_up < n_hypool_ag) then + + ! Path is between stem compartments + ! This condition is only possible if n_hypool_ag>2 + + znode_up = cohort_hydr%z_node_ag(inode_up) + znode_lo = cohort_hydr%z_node_ag(inode_lo) + !psinode_up = psi_node(inode_up) + !psinode_lo = psi_node(inode_lo) + kmax_up = cohort_hydr%kmax_stem_lower(inode_up-1) + kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-1) + + elseif(inode_up == n_hpool_ag) then + + ! Path is between lowest stem and transporting root + + znode_up = cohort_hydr%z_node_ag(n_hpool_ag) + znode_lo = cohort_hydr%z_node_troot + kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) + kmax_lo = cohort_hydr%kmax_troot_upper + + elseif(inode_up == n_hpool_ag) then + + ! Path is between the transporting root + ! and the absorbing root nodes + + znode_up = cohort_hydr%z_node_troot + znode_lo = bc_in%z_sisl(ilayer) + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - elseif(inode_up == n_hpool_ag+n_hypool_troot+1) then - ! Path is between the absorbing root and the 1st - ! rhizosphere shell compartment - - znode_up = bc_in(s)%z_sisl(ilayer) - znode_lo = bc_in(s)%z_sisl(ilayer) - psinode_up = psi_node(inode_up) - psinode_lo = psi_node(inode_lo) - - kmax_surf = - kmax_up=kmax_bound - kmax_lo=site_hydr%kmax_bound_shell(ilayer,inode_lo) + else + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + znode_up = bc_in%z_sisl(ilayer) + znode_lo = bc_in%z_sisl(ilayer) + + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + + if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) + else + kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) + end if + + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) else - ! Path is between rhizosphere shells - znode_up = bc_in(s)%z_sisl(ilayer) - znode_lo = bc_in(s)%z_sisl(ilayer) - psinode_up = psi_node(inode_up) - psinode_lo = psi_node(inode_lo) + ! Path is between rhizosphere shells + + znode_up = bc_in%z_sisl(ilayer) + znode_lo = bc_in%z_sisl(ilayer) - kmax_up=site_hydr%kmax_bound_shell(ilayer,inode_up) - kmax_lo=site_hydr%kmax_bound_shell(ilayer,inode_lo) + ishell_up = inode_up - n_hypool_ag + 2 ! Remove total number of plant pools from index + ishell_lo = ishell_up + 1 + kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) + kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) + end if - hdiff_bound(jpath) = mpa_per_pa*denh2o*grav_earth*(znode_up-znode_lo) + (psinode_up-psinode_lo) + + ! This is the potential difference between the nodes (matric and geopotential) + hdiff_bound(jpath) = mpa_per_pa*denh2o*grav_earth*(znode_up-znode_lo) + (psinode(inode_up)-psinode(inode_lo)) - ! examine direction of water flow; use the upstream node's k for the boundary k. - ! (as suggested by Ethan Coon, LANL) + + if(do_kbound_upstream) then + ! Examine direction of water flow; use the upstream node's k for the boundary k. + ! (as suggested by Ethan Coon, LANL) + if(hdiff_bound(jpath) < 0._r8) then ! More potential in the lower node, use its fraction of conductivity loss k_bound(jpath) = flc_node(inode_lo) / & @@ -114,6 +348,7 @@ subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node else + k_path(jpath) = ( @@ -167,70 +402,13 @@ subroutine HDiffK1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node dkbounddpsi0(k) = 0._r8 dkbounddpsi1(k) = 0._r8 - end subroutine HDiffK1D + end subroutine HDiffK1D subroutine PlantKmax() - ! ------------------------------------------------------------------------------ - ! Part II. Set maximum (size-dependent) hydraulic conductances - ! ------------------------------------------------------------------------------ - - ! first estimate cumulative (petiole to node k) conductances - ! without taper as well as the chi taper function - - do k=n_hypool_leaf,n_hypool_ag - dz_node1_lowerk = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_lower_ag(k) - if(k < n_hypool_ag) then - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_ag(k+1) - else - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_troot(1) - end if - kmax_node1_nodekplus1(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_nodekplus1 - kmax_node1_lowerk(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_lowerk - chi_node1_nodekplus1(k) = xylemtaper(taper_exponent, dz_node1_nodekplus1) - chi_node1_lowerk(k) = xylemtaper(taper_exponent, dz_node1_lowerk) - if(.not.do_kbound_upstream) then - if(crown_depth == 0._r8) then - write(fates_log(),*) 'do_kbound_upstream requires a nonzero canopy depth ' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - enddo - - ! then calculate the conductances at node boundaries as the difference of cumulative conductances - do k=n_hypool_leaf,n_hypool_ag - if(k == n_hypool_leaf) then - ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) - else - ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - end if - - enddo - - ! finally, estimate the remaining tree conductance belowground as a residual - - kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))** (-1._r8) - - kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft)* kmax_treeag_tot - - ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) - - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot - end do diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index cd3299242c..e882f711f4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -152,7 +152,7 @@ module FatesPlantHydraulicsMod public :: SavePreviousCompartmentVolumes public :: SavePreviousRhizVolumes public :: UpdateTreeHydrNodes - public :: UpdateTreeHydrLenVolCond + public :: UpdateTreeHydrLenVol public :: KmaxInnerShell public :: ConstrainRecruitNumber @@ -239,8 +239,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) call UpdateTreeHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) - ! This calculates volumes, lengths and max conductances - call UpdateTreeHydrLenVolCond(ccohort,sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) + ! This calculates volumes and lengths + call UpdateTreeHydrLenVol(ccohort,sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) + + ! This updates the Kmax's of the plant's compartments + call UpdatePlantKmax(ccohort_hydr,ccohort,sites(s)%si_hydr,bc_in(s)) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. @@ -456,37 +459,16 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem enddo - ! Transporting Root Nodes - ! in special case where n_hypool_troot = 1, the node depth of the single troot pool - ! is the depth at which 50% total root distribution is attained - dcumul_rf = 1._r8/real(n_hypool_troot,r8) + ! Transporting Root Node depth [m] (negative from surface) - do k=1,n_hypool_troot - cumul_rf = dcumul_rf*real(k,r8) - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_lower_troot(k) = -z_cumul_rf - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf-0.5_r8*dcumul_rf, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_node_troot(k) = -z_cumul_rf - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & - 0.001_r8, 0.001_r8, cumul_rf-1.0_r8*dcumul_rf+1.E-10_r8, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) - ccohort_hydr%z_upper_troot(k) = -z_cumul_rf - enddo + call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) + z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) + ccohort_hydr%z_node_troot = -z_cumul_rf - ! Absorbing root depth - ccohort_hydr%z_node_aroot(1:nlevsoi_hyd) = -bc_in%z_sisl(1:nlevsoi_hyd) - ! Shouldn't this be updating the upper and lower values as well? - ! (RGK 12-2018) - if(nlevsoi_hyd == 1) then - ccohort_hydr%z_node_troot(:) = ccohort_hydr%z_node_aroot(nlevsoi_hyd) - end if return end subroutine UpdateTreeHydrNodes @@ -548,7 +530,11 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdateTreeHydrNodes is called prior to this. - call UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) + call UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) + + ! This updates the Kmax's of the plant's compartments + call UpdatePlantKmax(ccohort_hydr,ccohort,currentsite%si_hydr,bc_in) + end subroutine updateSizeDepTreeHydProps @@ -590,14 +576,13 @@ end subroutine updateWaterDepTreeHydProps ! ===================================================================================== - subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) + subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! ----------------------------------------------------------------------------------- - ! This subroutine calculates three attributes of a plant: + ! This subroutine calculates two attributes of a plant: ! 1) the volumes of storage compartments in the plants ! 2) the lenghts of the organs - ! 3) the conductances - ! These and are not dependent on the hydraulic state of the + ! These are not dependent on the hydraulic state of the ! plant, it is more about the structural characteristics and how much biomass ! is present in the different tissues. ! @@ -641,23 +626,8 @@ subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) real(r8) :: v_troot ! transporting root volume [m3/indiv] real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] - real(r8) :: kmax_node1_nodekplus1(n_hypool_ag) ! cumulative kmax, petiole to node k+1, - ! conduit taper effects excluded [kg s-1 MPa-1] - real(r8) :: kmax_node1_lowerk(n_hypool_ag) ! cumulative kmax, petiole to upper boundary of node k, - ! conduit taper effects excluded [kg s-1 MPa-1] - real(r8) :: chi_node1_nodekplus1(n_hypool_ag) ! ratio of cumulative kmax with taper effects - ! included to that without [-] - real(r8) :: chi_node1_lowerk(n_hypool_ag) ! ratio of cumulative kmax with taper effects - ! included to that without [-] - real(r8) :: dz_node1_nodekplus1 ! cumulative distance between canopy - ! node and node k + 1 [m] - real(r8) :: dz_node1_lowerk ! cumulative distance between canopy - ! node and upper boundary of node k [m] - real(r8) :: kmax_treeag_tot ! total stem (petiole to transporting root node) - ! hydraulic conductance [kg s-1 MPa-1] - real(r8) :: kmax_tot ! total tree (leaf to root tip) - ! hydraulic conductance [kg s-1 MPa-1] - real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] + + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft @@ -763,81 +733,9 @@ subroutine UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot end do - - ! ------------------------------------------------------------------------------ - ! Part II. Set maximum (size-dependent) hydraulic conductances - ! ------------------------------------------------------------------------------ - - ! first estimate cumulative (petiole to node k) conductances - ! without taper as well as the chi taper function - - do k=n_hypool_leaf,n_hypool_ag - dz_node1_lowerk = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_lower_ag(k) - if(k < n_hypool_ag) then - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_ag(k+1) - else - dz_node1_nodekplus1 = ccohort_hydr%z_node_ag(n_hypool_leaf) & - - ccohort_hydr%z_node_troot(1) - end if - kmax_node1_nodekplus1(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_nodekplus1 - kmax_node1_lowerk(k) = EDPftvarcon_inst%hydr_kmax_node(ft,2) * a_sapwood / dz_node1_lowerk - chi_node1_nodekplus1(k) = xylemtaper(taper_exponent, dz_node1_nodekplus1) - chi_node1_lowerk(k) = xylemtaper(taper_exponent, dz_node1_lowerk) - if(.not.do_kbound_upstream) then - if(crown_depth == 0._r8) then - write(fates_log(),*) 'do_kbound_upstream requires a nonzero canopy depth ' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - enddo - - - ! then calculate the conductances at node boundaries as the difference of cumulative conductances - do k=n_hypool_leaf,n_hypool_ag - if(k == n_hypool_leaf) then - ccohort_hydr%kmax_bound(k) = kmax_node1_nodekplus1(k) * chi_node1_nodekplus1(k) - else - ccohort_hydr%kmax_bound(k) = ( 1._r8/(kmax_node1_nodekplus1(k) *chi_node1_nodekplus1(k) ) - & - 1._r8/(kmax_node1_nodekplus1(k-1)*chi_node1_nodekplus1(k-1)) ) ** (-1._r8) - end if - -!!!!!!!!!! FOR TESTING ONLY - !ccohort_hydr%kmax_bound(:) = 0.02_r8 ! Diurnal lwp variation in coldstart: -0.1 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: less than -0.01 MPa - !ccohort_hydr%kmax_bound(:) = 0.0016_r8 ! Diurnal lwp variation in coldstart: -0.8 - 1.0 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -1.5 - 2.0 MPa [seemingly unstable] - !ccohort_hydr%kmax_bound(:) = 0.0008_r8 ! Diurnal lwp variation in coldstart: -1.5 - 2.0 MPa - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -2.0 - 3.0 MPa [seemingly unstable] - !ccohort_hydr%kmax_bound(:) = 0.0005_r8 ! Diurnal lwp variation in coldstart: -2.0 - 3.0 MPa and one -5 MPa outlier - ! Diurnal lwp variation in large-tree (50cmDBH) coldstart: -3.0 - 4.0 MPa and one -10 MPa outlier [Unstable] -!!!!!!!!!! - - enddo - - ! finally, estimate the remaining tree conductance belowground as a residual - - kmax_treeag_tot = sum(1._r8/ccohort_hydr%kmax_bound(n_hypool_leaf:n_hypool_ag))** (-1._r8) - - kmax_tot = EDPftvarcon_inst%hydr_rfrac_stem(ft)* kmax_treeag_tot - - ccohort_hydr%kmax_treebg_tot = ( 1._r8/kmax_tot - 1._r8/kmax_treeag_tot ) ** (-1._r8) - - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%kmax_treebg_layer(j) = rootfr*ccohort_hydr%kmax_treebg_tot - end do - - end if !check for bleaf - end subroutine UpdateTreeHydrLenVolCond + end subroutine UpdateTreeHydrLenVol !===================================================================================== @@ -2615,6 +2513,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! radial absorbing root conductance: factor of 2 means one-half of the ! total belowground resistance in layer j kmax_bound_aroot_soil1 = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) + ! (root surface)-to-(soil shell#1) conductance kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) @@ -2625,6 +2524,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) kmax_lower_1l(n_hypool_ag+2) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) + ! REMEMBER: kmax_bound_shell_1l defined at the uppper (closer to atmosphere) ! boundary for each node, while kmax_bound_1l defined at the lower ! (closer to bulk soil) boundary for each node diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index fdd71be12f..13412c4d3f 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -23,8 +23,8 @@ module FatesHydraulicsMemMod integer, parameter, public :: n_hypool_leaf = 1 integer, parameter, public :: n_hypool_stem = 1 - integer, parameter, public :: n_hypool_troot = 1 - integer, parameter, public :: n_hypool_aroot = 1 + integer, parameter, public :: n_hypool_troot = 1 ! CANNOT BE CHANGED + integer, parameter, public :: n_hypool_aroot = 1 ! THIS IS "PER-SOIL-LAYER" integer, parameter, public :: nshell = 5 ! number of aboveground plant water storage nodes @@ -177,33 +177,47 @@ module FatesHydraulicsMemMod end type ed_site_hydr_type - ! This whole structure is actually not used, because netRad_mem() is actually not used - ! Keeping the code in place in case a patch-level hydraulics variable is desired (RGK 03-2018) - - !type ed_patch_hydr_type - ! real(r8) :: netRad_mem(numLWPmem) ! patch-level net radiation for the previous numLWPmem timesteps [W m-2] - !end type ed_patch_hydr_type type, public :: ed_cohort_hydr_type - - ! BC...PLANT HYDRAULICS - "constants" that change with size. + + + ! Node heights of compartments [m] ! Heights are referenced to soil surface (+ = above; - = below) - real(r8) :: z_node_ag(n_hypool_ag+n_hypool_troot) ! nodal height of non-layered water storage compartments [m] + ! Note* The node centers of the absorbing root compartments, are the same + ! as the soil layer mid-points that they occupy, so no need to save those. + ! ---------------------------------------------------------------------------------- + real(r8) :: z_node_ag(n_hypool_ag) ! nodal height of stem and leaf compartments (positive) + real(r8) :: z_upper_ag(n_hypool_ag) ! height of upper stem and leaf compartment boundaries (positive) + real(r8) :: z_lower_ag(n_hypool_ag) ! height of lower stem and leaf compartment boundaries (positive) + real(r8) :: z_node_troot ! nodal height of transporting root (negative) + - ! Maximum conductances + ! Maximum hydraulic conductances [kg H2O s-1 MPa-1] ! ---------------------------------------------------------------------------------- - real(r8) :: kmax_ag(n_hypool_ag) ! maximum hydraulic conductance of non-layered compartments [kg s-1 MPa-1] - real(r8),allocatable :: kmax_treebg_layer(:) ! total belowground tree kmax partitioned by soil layer [kg s-1 MPa-1] - real(r8),allocatable :: kmax_rsurf_in(:) ! Maximum hydraulic conductance of the root surface when - ! potential gradient is "in" to root - ! (kg s-1 MPa-1) - real(r8),allocatable :: kmax_rsurf_out(:) ! Maximum hydraulic conductance of the root surface when - ! potential gradient is "out" of root - ! (kg s-1 MPa-1) - + real(r8) :: kmax_petiole_to_leaf ! Max conductance, petiole to leaf + ! Nominally set to very high value + real(r8) :: kmax_stem_upper(n_hypool_stem) ! Max conductance, upper stem compartments + real(r8) :: kmax_stem_lower(n_hypool_stem) ! Max conductance, lower stem compartments + real(r8) :: kmax_troot_upper ! Max conductance, uper portion of the + ! transporting root + real(r8),allocatable :: kmax_troot_lower(:) ! Max conductance in portion of transporting + ! root compartment that joins each absorbing + ! root compartment + real(r8),allocatable :: kmax_aroot_upper(:) ! Max conductance in the absorbing root + ! compartment through xylem tissues going + ! into the transporting root + + ! Max conductance in the absorbing + ! root compartment, radially through the + ! exodermis, cortex, casparian strip, and + ! endodermis, separated for two cases, when: + real(r8),allocatable :: kmax_aroot_radial_in(:) ! the potential gradient is positive "into" root + real(r8),allocatable :: kmax_aroot_radial_out(:) ! the potential gradient is positive "out of" root + + ! Compartment Volumes and lengths real(r8) :: v_ag_init(n_hypool_ag) ! previous day's volume of aboveground water storage compartments [m3] From 4e368aa3f985561cdb963bcad71b6fd8be4ba7b4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 19 Aug 2019 16:39:11 -0700 Subject: [PATCH 006/114] hydraulics, fix refactor of stem kmax, follow Brads tech-note more closely. --- biogeophys/FatesHydroSolversMod.F90 | 100 ++++++++++++++----------- biogeophys/FatesPlantHydraulicsMod.F90 | 25 ++++++- 2 files changed, 78 insertions(+), 47 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index 534f25b825..17e6867417 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -44,12 +44,12 @@ subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) integer :: k_ag ! Compartment index for above-ground indexed array integer :: pft ! Plant Functional Type index real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] - real(r8) :: z_lower ! Elevation of the center of lower compartment [m] - real(r8) :: z_upper ! Elevation of the center of upper compartment [m] - real(r8) :: dz_pet_upper ! Distance of upper compartment center to petiol [m] - real(r8) :: dz_pet_lower ! Distance of loewr compartment center to petiol [m] - real(r8) :: dz_lower ! Path length of the lower compartment [m] - real(r8) :: dz_upper ! Path length of the upper compartment [m] + real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] + real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] + real(r8) :: z_node ! distance between compartment center and mph [m] + real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways ! [kg-1 s MPa] @@ -82,8 +82,6 @@ subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! center of storage, to the petiole. ccohort_hydr%kmax_petiole_to_leaf = 1.e12_r8 - - ! Stem Maximum Hydraulic Conductance @@ -94,43 +92,60 @@ subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! in one vector k_ag = k+n_hypool_leaf - ! Elevation of the upper and lower compartment mid-points [m] + ! Depth from the petiole to the lower, node and upper compartment edges - z_lower = 0.5_r8*(ccohort_hydr%z_node_ag(k_ag) + ccohort_hydr%z_lower_ag(k_ag)) - z_upper = 0.5_r8*(ccohort_hydr%z_node_ag(k_ag) + ccohort_hydr%z_upper_ag(k_ag)) + z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) + z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) + z_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_upper_ag(k_ag) - ! Distance from the center of the two compartments, to the petiole [m] - dz_pet_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_upper - dz_pet_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_lower + ! Then we calculate the maximum conductance from each the lower, node and upper + ! edges of the compartment to the petiole. The xylem taper factor requires + ! that the kmax it is scaling is from the point of interest to the mean height + ! of the petioles. Then we can back out the conductance over just the path + ! of the upper and lower compartments, but subtracting them as resistors in + ! series. + ! max conductance from upper edge to mean petiole height + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_upper) * & + a_sapwood / z_upper - ! Path-length of the compartments [m] + ! max conductance from node to mean petiole height + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_node) * & + a_sapwood / z_node - dz_upper = ccohort_hydr%z_upper_ag(k_ag) - ccohort_hydr%z_node_ag(k_ag) - dz_lower = ccohort_hydr%z_node_ag(k_ag) - ccohort_hydr%z_lower_ag(k_ag) + ! max conductance from lower edge to mean petiole height + kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_lower) * & + a_sapwood / z_lower - + ! Max conductance over the path of the upper side of the compartment + ccohort_hydr%kmax_stem_upper(k_ag) = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 + + ! Max conductance over the path on the loewr side of the compartment + ccohort_hydr%kmax_stem_lower(k_ag) = (1._r8/kmax_lower - 1._r8/kmax_node)**-1._r8 - ccohort_hydr%kmax_stem_upper(k_ag) = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, dz_pet_upper) * & - a_sapwood / dz_upper - ccohort_hydr%kmax_stem_lower(k_ag) = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, dz_pet_lower) * & - a_sapwood / dz_lower enddo ! Maximum conductance of the upper compartment in the transporting root ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - z_upper = 0.5*(ccohort_hydr%z_lower_ag(n_hypool_ag)+ccohort_hydr%z_node_troot) - dz_pet_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - z_upper - dz_upper = z_upper - ccohort_hydr%z_node_troot + z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) + z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot + + + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_node) * & + a_sapwood / z_node + + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_upper) * & + a_sapwood / z_upper - ccohort_hydr%kmax_troot_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, dz_pet_upper) * & - a_sapwood / dz_upper + ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 ! The maximum conductance between the center node of the transporting root @@ -209,7 +224,7 @@ end subroutine UpdatePlantKMax - subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflcdpsi_node, & + subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,jpaths,ilayer,psi_node,flc_node,dflcdpsi_node, & hdiff_bound,k_bound,dhdiffdpsi0,dhdiffdpsi1,dkbounddpsi0,dkbounddpsi1) ! ------------------------------------------------------------------------------------------ @@ -268,10 +283,8 @@ subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflc znode_up = cohort_hydr%z_node_ag(inode_up) znode_lo = cohort_hydr%z_node_ag(inode_lo) - !psinode_up = psi_node(inode_up) - !psinode_lo = psi_node(inode_lo) - kmax_up = cohort_hydr%kmax_stem_lower(inode_up-1) - kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-1) + kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) + kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) elseif(inode_up == n_hpool_ag) then @@ -326,7 +339,7 @@ subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflc kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) end if - + ! This is the potential difference between the nodes (matric and geopotential) hdiff_bound(jpath) = mpa_per_pa*denh2o*grav_earth*(znode_up-znode_lo) + (psinode(inode_up)-psinode(inode_lo)) @@ -338,13 +351,14 @@ subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,inodes,psi_node,flc_node,dflc ! Examine direction of water flow; use the upstream node's k for the boundary k. ! (as suggested by Ethan Coon, LANL) - - if(hdiff_bound(jpath) < 0._r8) then - ! More potential in the lower node, use its fraction of conductivity loss - k_bound(jpath) = flc_node(inode_lo) / & - (1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) * flc_node(k+1) ! water moving towards atmosphere - dkdpsi0(jpath) = 0._r8 - dkdpsi1(jpath) = kmax_bound(jpath) * dflcdpsi_node(inode_lo) + + if(hdiff_bound(jpath) < 0._r8) then + ! More potential in the lower node, use its fraction of conductivity loss + k_bound(jpath) = flc_node(inode_lo) / & + (1._r8/kmax_lo + 1._r8/kmax_up) + (1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) * flc_node(k+1) ! water moving towards atmosphere + dkdpsi0(jpath) = 0._r8 + dkdpsi1(jpath) = kmax_bound(jpath) * dflcdpsi_node(inode_lo) else diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index e882f711f4..ce71dc61dc 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1641,12 +1641,12 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) type(ed_cohort_type) , pointer :: cCohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] + ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the - ! innermost shell radius is less than the assumed - ! absorbing root radius rs1 - ! 1.e-5_r8 from Rudinger et al 1994 + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 integer :: nlevsoi_hyd !----------------------------------------------------------------------- @@ -1691,6 +1691,23 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! proceed only if the total absorbing root length (site-level) has changed in this layer if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + k_inner = 1 + + ! Set the max conductance on the inner shell first. If the node radius + ! on the shell is smaller than the root radius, just set the max conductance + ! to something extremely high. + + if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then + csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound + else + csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + end if + + csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s + + do k = 2,nshell csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s From 25d1e811406c938ccf9b53c78cd2f7c0f4f2f346 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 26 Aug 2019 10:07:23 -0700 Subject: [PATCH 007/114] hydro solver refactors, 1d serial --- biogeophys/FatesHydroSolversMod.F90 | 438 +++++++++++++++++----------- 1 file changed, 263 insertions(+), 175 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index 17e6867417..a430b94c60 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -222,214 +222,302 @@ subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) return end subroutine UpdatePlantKMax + ! =================================================================================== + subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms) - subroutine UpdateHDiffCond1D(cohort_hydr,site_hydr,jpaths,ilayer,psi_node,flc_node,dflcdpsi_node, & - hdiff_bound,k_bound,dhdiffdpsi0,dhdiffdpsi1,dkbounddpsi0,dkbounddpsi1) - - ! ------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and ! the list need not be across the whole path from stomata to the last rhizosphere shell, but ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. - ! ------------------------------------------------------------------------------------------ + ! ------------------------------------------------------------------------------- ! !ARGUMENTS type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr type(ed_site_hydr_type), intent(in),target :: site_hydr - integer , intent(in) :: jpaths(:) ! The path indices that are to be calculated - integer , intent(in) :: ilayer ! soil layer index of interest - real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] - real(r8) , intent(in) :: dflcdpsi_node(:) ! derivative of fractional loss of conductivity wrt psi [MPa-1] - real(r8) , intent(out) :: hdiff_bound(:) ! total water potential difference across lower boundary [MPa] - real(r8) , intent(out) :: k_bound(:) ! lower boundary hydraulic conductance of compartments [kg s-1 MPa-1] - real(r8) , intent(out) :: dhdiffdpsi0(:) ! derivative of total water potential difference wrt psi above [-] - real(r8) , intent(out) :: dhdiffdpsi1(:) ! derivative of total water potential difference wrt psi below [-] - real(r8) , intent(out) :: dkbounddpsi0(:) ! derivative of lower boundary conductance wrt psi above [kg s-1 MPa-2] - real(r8) , intent(out) :: dkbounddpsi1(:) ! derivative of lower boundary conductance wrt psi below [kg s-1 MPa-2] - - - ! !LOCAL VARIABLES: - integer :: inode_up ! node index closest to atmosphere for the path of interest - integer :: inode_lo ! node index further from atmosphere for path of interest - integer :: jpath ! path index - real(r8) :: k_bound_aroot_soil1 ! radial conductance of absorbing roots [kg s-1 MPa-1] - real(r8) :: k_bound_aroot_soil2 ! conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] - real(r8) :: k_lower ! conductance node k to lower boundary [kg s-1 MPa-1] - real(r8) :: k_upper ! conductance node k+1 to upper boundary [kg s-1 MPa-1] - !---------------------------------------------------------------------- - - do j=1,size(jpaths,1) - - jpath=jpaths(j) - - inode_up = jpath - inode_lo = jpath+1 - - if(inode_up == 1) then - - ! Path is between the leaf node and first stem node - - istem = 1 - - znode_up = cohort_hydr%z_node_ag(inode_up) - znode_lo = cohort_hydr%z_node_ag(inode_lo) - kmax_up = cohort_hydr%kmax_petiole_to_leaf - kmax_lo = cohort_hydr%kmax_stem_upper(1) - - elseif(inode_up < n_hypool_ag) then - - ! Path is between stem compartments - ! This condition is only possible if n_hypool_ag>2 - - znode_up = cohort_hydr%z_node_ag(inode_up) - znode_lo = cohort_hydr%z_node_ag(inode_lo) - kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) - kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) - - elseif(inode_up == n_hpool_ag) then - - ! Path is between lowest stem and transporting root - - znode_up = cohort_hydr%z_node_ag(n_hpool_ag) - znode_lo = cohort_hydr%z_node_troot - kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) - kmax_lo = cohort_hydr%kmax_troot_upper - - elseif(inode_up == n_hpool_ag) then - - ! Path is between the transporting root - ! and the absorbing root nodes - - znode_up = cohort_hydr%z_node_troot - znode_lo = bc_in%z_sisl(ilayer) - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - else - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - znode_up = bc_in%z_sisl(ilayer) - znode_lo = bc_in%z_sisl(ilayer) - - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - - if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then - kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) - else - kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) - end if - - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) - - else - - ! Path is between rhizosphere shells - - znode_up = bc_in%z_sisl(ilayer) - znode_lo = bc_in%z_sisl(ilayer) - - ishell_up = inode_up - n_hypool_ag + 2 ! Remove total number of plant pools from index - ishell_lo = ishell_up + 1 - - kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) - kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) - - end if - - - ! This is the potential difference between the nodes (matric and geopotential) - hdiff_bound(jpath) = mpa_per_pa*denh2o*grav_earth*(znode_up-znode_lo) + (psinode(inode_up)-psinode(inode_lo)) - - - - - if(do_kbound_upstream) then - - ! Examine direction of water flow; use the upstream node's k for the boundary k. - ! (as suggested by Ethan Coon, LANL) - - if(hdiff_bound(jpath) < 0._r8) then - ! More potential in the lower node, use its fraction of conductivity loss - k_bound(jpath) = flc_node(inode_lo) / & - (1._r8/kmax_lo + 1._r8/kmax_up) - (1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) * flc_node(k+1) ! water moving towards atmosphere - dkdpsi0(jpath) = 0._r8 - dkdpsi1(jpath) = kmax_bound(jpath) * dflcdpsi_node(inode_lo) - - else + integer , intent(in) :: ilayer ! soil layer index of interest + real(r8) , intent(in) :: psi_node(:) ! matric potential of nodes [Mpa] + real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] + real(r8), intent(out),optional :: trisolve_terms(:,:) ! This contains the terms for a tri-diagonal matrix + ! which contains the constant term on the left side [col=1] + ! and for each node's solution, the terms for that node [col=3] + ! and its flanking nodes [i-1: col=2] and [i+1: col=3] + + ! Locals + + integer :: inode ! node index "i" + integer :: jpath ! path index "j" + integer :: ishell ! rhizosphere shell index of the node + integer :: i_dn ! downstream node of current flow-path + integer :: i_up ! upstream node of current flow-path + real(r8) :: kmax_up ! maximum conductance of the upstream half of path [kg s-1 Mpa-1] + real(r8) :: kmax_dn ! maximum conductance of the downstream half of path [kg s-1 MPa-1] + real(r8) :: th_node ! "theta" i.e. water content of node [m3 m-3] + real(r8) :: z_node ! elevation of node [m] + real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] + real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] + real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] + real(r8) :: dftc_dtheta_node(n_hypool_tot) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(n_hypool_tot) ! deriv psi w.r.t. theta + real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] + real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] + real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] + + ! ------------------------------------------------------------------------------- + ! Part 1. Calculate node quantities: + ! matric potential: psi_node + ! fraction of total conductance: ftc_node + ! total potential (matric + elevatio) h_node + ! deriv. ftc wrt theta: dftc_dtheta_node + ! deriv. psi wrt theta: dpsi_dtheta_node + ! ------------------------------------------------------------------------------- + + + + ! For leaf and stem pools + + do inode = 1,n_hypool_tot + + if (inode<=n_hypool_ag) then + th_node = ccohort_hydr%th_ag(inode) + z_node = ccohort_hydr%z_node_ag(inode) + elseif (inode==n_hypool_ag+1) then + th_node = ccohort_hydr%th_troot(1) + z_node = ccohort_hydr%z_node_troot + elseif (inode==n_hyppol_ag+2) then + th_node = ccohort_hyd%th_aroot(ilayer) + z_node = bc_in(s)%z_sisl(ilayer) + else + ishell = inode-(n_hypool_tot+2) + th_node = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) + z_node = bc_in(s)%z_sisl(ilayer) + end if - k_path(jpath) = ( + ! Get matric potential [Mpa] + call psi_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & + psi_node(inode), site_hydr, bc_in) - + ! Get total potential [Mpa] + h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + ! Get Fraction of Total Conductivity [-] + call flc_from_psi(currentCohort%pft, porous_media(inode), ccohort_hydr%psi_ag(inode), & + ftc_node(inode), site_hydr, bc_in) + ! deriv ftc wrt theta + call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & + dpsi_dtheta_node(inode), site_hydr, bc_in) + + call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + dftc_dpsi, site_hydr, bc_in) + + dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) - end if - end if + end do - if(do_kbound_upstream) then + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- - ! absorbing root-1st rhizosphere shell boundary. - ! Comprised of two distinct conductance terms each with distinct water potentials + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- - if(k == (k_arootsoil)) then + jpath = 1 + i_dn = 1 + i_up = 2 + kmax_dn = cohort_hydr%kmax_petiole_to_leaf + kmax_up = cohort_hydr%kmax_stem_upper(1) - k_bound_aroot_soil1 = kmax_bound_aroot_soil1 * flc_node(k) - k_bound_aroot_soil2 = kmax_bound_aroot_soil2 * flc_node(k+1) + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + - k_bound(k) = 1._r8/(1._r8/k_bound_aroot_soil1 + 1._r8/k_bound_aroot_soil2) + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- - dkbounddpsi0(k) = ((k_bound(k)/k_bound_aroot_soil1)**2._r8) * & - kmax_bound_aroot_soil1*dflcdpsi_node(k) - dkbounddpsi1(k) = ((k_bound(k)/k_bound_aroot_soil2)**2._r8) * & - kmax_bound_aroot_soil2*dflcdpsi_node(k+1) - else - ! examine direction of water flow; use the upstream node's k for the boundary k. - ! (as suggested by Ethan Coon, LANL) - if(hdiff_bound(k) < 0._r8) then - k_bound(k) = kmax_bound(k) * flc_node(k+1) ! water moving towards atmosphere - dkbounddpsi0(k) = 0._r8 - dkbounddpsi1(k) = kmax_bound(k) * dflcdpsi_node(k+1) - else - k_bound(k) = kmax_bound(k) * flc_node(k) ! water moving towards soil - dkbounddpsi0(k) = kmax_bound(k) * dflcdpsi_node(k) - dkbounddpsi1(k) = 0._r8 - end if - end if - else - k_lower = kmax_lower(k) * flc_node(k) - k_upper = kmax_upper(k+1) * flc_node(k+1) - k_bound(k) = 1._r8/(1._r8/k_lower + 1._r8/k_upper) - dkbounddpsi0(k) = ((k_bound(k)/k_lower)**2._r8) * kmax_lower(k) * dflcdpsi_node(k) - dkbounddpsi1(k) = ((k_bound(k)/k_upper)**2._r8) * kmax_upper(k+1)* dflcdpsi_node(k+1) - end if - dhdiffdpsi0(k) = 1.0 - dhdiffdpsi1(k) = -1.0 - enddo - k = size(z_node) - k_bound(k) = 0._r8 - dkbounddpsi0(k) = 0._r8 - dkbounddpsi1(k) = 0._r8 + do jpath=2,n_hypool_ag-1 - end subroutine HDiffK1D + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) + kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + end do + + ! Path is between lowest stem and transporting root + + jpath = n_hypool_ag + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) + kmax_lo = cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + - subroutine PlantKmax() + ! Path is between the absorbing root and the first + ! rhizosphere + jpath = n_hypool_ag+1 + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + jpath = n_hypool_ag+2 + i_dn = jpath + i_up = jpath+1 + + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) + else + kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) + end if + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + ! Path is between rhizosphere shells + + do jpath = n_hypool_ag+3,n_hpool_tot-1 + + i_dn = jpath + i_up = jpath+1 + ishell_dn = i_dn - (n_hypool_ag+2) + ishell_up = i_up - (n_hypool_ag+2) + kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) + kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + end do + + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- + + do inode = 1,n_hypool_tot + a(inode) + b(inode) + c(inode) + r(inode) + end do + - end subroutine PlantKmax + return + end subroutine ImTaylorSolverTermsCond1D + + ! ================================================================================= + + subroutine GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_up,ftc_dn, & + h_up,h_dn, & + dftc_dtheta_up, dftc_dtheta_dn, & + dpsi_dtheta_up, dpsi_dtheta_dn, & + k_eff, & + A_term, & + B_term) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction from upstream node to downstream node. + ! ----------------------------------------------------------------------------- + + real(r8),intent(in) :: kmax_up, kmax_dn ! max conductance [kg s-1 Mpa-1] + real(r8),intent(in) :: ftc_up, ftc_dn ! frac total conductance [-] + real(r8),intent(in) :: h_up, h_dn ! total potential [Mpa] + real(r8),intent(in) :: dftc_dtheta_up, dftc_dtheta_dn ! Derivative + ! of FTC wrt relative water content + + real(r8),intent(in) :: dpsi_dtheta_up, dpsi_dtheta_dn ! Derivative of matric potential + ! wrt relative water content + + real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(in) :: a_term ! "A" term for path (See tech note) + real(r8),intent(in) :: b_term ! "B" term for path (See tech note) + + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_dn*kmax_dn)+1._r8/(ftc_up*kmax_up)) + + ! Calculate difference in total potential over the path [MPa] + h_diff = h_up - h_dn + + ! "A" term, which operates on the down-stream node + A_term = (k_eff**2.0_r8) * h_diff * (kmax_dn**-1.0_r8) * (ftc_dn**-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + + ! "B" term, which operates on the up-stream node + B_term = (k_eff**2.0_r8) * h_diff * (kmax_up**-1.0_r8) * (ftc_up**-2.0_r8) & + * dftc_dtheta_up + k_eff * dpsi_dtheta_up + + return + end subroutine GetImTaylorTerms From 8ded734e75f72b7c8f947dc1c0cb8795fc114904 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 29 Aug 2019 11:41:38 -0700 Subject: [PATCH 008/114] More refactors of 1d hydro solve --- biogeophys/FatesHydroSolversMod.F90 | 508 +++++++++++++++++-------- biogeophys/FatesPlantHydraulicsMod.F90 | 340 ++++++----------- main/FatesHydraulicsMemMod.F90 | 2 - 3 files changed, 464 insertions(+), 386 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index a430b94c60..1b16fbcae6 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -224,7 +224,7 @@ end subroutine UpdatePlantKMax ! =================================================================================== - subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms) + subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top,d_th_node,sapflow,rootuptake,wb_err) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -238,11 +238,17 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms integer , intent(in) :: ilayer ! soil layer index of interest real(r8) , intent(in) :: psi_node(:) ! matric potential of nodes [Mpa] real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] - real(r8), intent(out),optional :: trisolve_terms(:,:) ! This contains the terms for a tri-diagonal matrix - ! which contains the constant term on the left side [col=1] - ! and for each node's solution, the terms for that node [col=3] - ! and its flanking nodes [i-1: col=2] and [i+1: col=3] + real(r8) , intent(in) :: dt_step ! time [seconds] over-which to calculate solution + real(r8) , intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + real(r8),intent(out) :: d_th_node(n_hypool_tot) ! change in theta over the timestep + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: wb_err ! transpiration should match change in storage [kg] + + + + ! Locals integer :: inode ! node index "i" @@ -252,8 +258,11 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms integer :: i_up ! upstream node of current flow-path real(r8) :: kmax_up ! maximum conductance of the upstream half of path [kg s-1 Mpa-1] real(r8) :: kmax_dn ! maximum conductance of the downstream half of path [kg s-1 MPa-1] - real(r8) :: th_node ! "theta" i.e. water content of node [m3 m-3] - real(r8) :: z_node ! elevation of node [m] + real(r8) :: wb_step_err + real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] + real(r8) :: th_node(n_hypool_tot) + real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] + real(r8) :: v_node(n_hypool_tot) ! volume of the node [m3] real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] @@ -262,6 +271,11 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] + real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_r(n_hypool_tot) + ! ------------------------------------------------------------------------------- ! Part 1. Calculate node quantities: @@ -274,193 +288,349 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,trisolve_terms - ! For leaf and stem pools - + ! For all nodes leaf through rhizosphere + ! Send node heights and compartment volumes to a node-based array + do inode = 1,n_hypool_tot if (inode<=n_hypool_ag) then - th_node = ccohort_hydr%th_ag(inode) - z_node = ccohort_hydr%z_node_ag(inode) + z_node(inode) = ccohort_hydr%z_node_ag(inode) + v_node(inode) = ccohort_hydr%v_node_ag(inode) + th_node_init(inode) = ccohort_hydr%th_ag(inode) elseif (inode==n_hypool_ag+1) then - th_node = ccohort_hydr%th_troot(1) - z_node = ccohort_hydr%z_node_troot + z_node(inode) = ccohort_hydr%z_node_troot + v_node(inode) = ccohort_hydr%v_troot(1) + th_node_init(inode) = ccohort_hydr%th_troot(1) elseif (inode==n_hyppol_ag+2) then - th_node = ccohort_hyd%th_aroot(ilayer) - z_node = bc_in(s)%z_sisl(ilayer) + z_node(inode) = bc_in(s)%z_sisl(ilayer) + v_node(inode) = ccohort_hydr%v_aroot_layer(:) + th_node_init(inode) = ccohort_hyd%th_aroot(ilayer) else ishell = inode-(n_hypool_tot+2) - th_node = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) - z_node = bc_in(s)%z_sisl(ilayer) + z_node(inode) = bc_in(s)%z_sisl(ilayer) + v_node(inode) = csite_hydr%v_shell(ilayer,ishell) + th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) end if - ! Get matric potential [Mpa] - call psi_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & - psi_node(inode), site_hydr, bc_in) + end do - ! Get total potential [Mpa] - h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) - ! Get Fraction of Total Conductivity [-] - call flc_from_psi(currentCohort%pft, porous_media(inode), ccohort_hydr%psi_ag(inode), & - ftc_node(inode), site_hydr, bc_in) + ! Outer iteration loop + ! This cuts timestep in half and resolve the solution with smaller substeps + ! This loop is cleared when the model has found a solution - ! deriv ftc wrt theta - call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & - dpsi_dtheta_node(inode), site_hydr, bc_in) + solution_found = .false. + iter = 0 + do while( .not.solution_found ) + + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps - call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & - dftc_dpsi, site_hydr, bc_in) + sapflow = 0._r8 + rootuptake = 0._r8 + wb_err = 0._r8 + + ! Gracefully quit if this is not going so well + if(iter>max_iter)then + write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' + write(fates_log(),*) '' + leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & + ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + + root_water = (sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',ccohort%dbh + write(fates_log(),*) 'pft: ',ccohort%pft + write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) - end do - - - !-------------------------------------------------------------------------------- - ! Part 2. Effective conductances over the path-length and Flux terms - ! over the node-to-node paths - !-------------------------------------------------------------------------------- - - ! Path is between the leaf node and first stem node - ! ------------------------------------------------------------------------------- + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) - jpath = 1 - i_dn = 1 - i_up = 2 - kmax_dn = cohort_hydr%kmax_petiole_to_leaf - kmax_up = cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- + ! Determine how many substeps, and how long they are - do jpath=2,n_hypool_ag-1 + nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) - kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds + + ! Walk through sub-steps + do istep = 1,nsteps + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + + ! Calculate on-node quantities: potential, and derivatives + do inode = 1,n_hypool_tot + + ! Get matric potential [Mpa] + call psi_from_th(currentCohort%pft, porous_media(inode), th_node(inode), & + psi_node(inode), site_hydr, bc_in) + + ! Get total potential [Mpa] + h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + + ! Get Fraction of Total Conductivity [-] + call flc_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + ftc_node(inode), site_hydr, bc_in) + + ! deriv ftc wrt theta + call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & + dpsi_dtheta_node(inode), site_hydr, bc_in) + + call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + dftc_dpsi, site_hydr, bc_in) + + dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) + + end do + + + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- + + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- + + jpath = 1 + i_dn = 1 + i_up = 2 + kmax_dn = cohort_hydr%kmax_petiole_to_leaf + kmax_up = cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do jpath=2,n_hypool_ag-1 + + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) + kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + end do + + + ! Path is between lowest stem and transporting root + + jpath = n_hypool_ag + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) + kmax_lo = cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between the absorbing root and the first + ! rhizosphere + + jpath = n_hypool_ag+1 + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + jpath = n_hypool_ag+2 + i_dn = jpath + i_up = jpath+1 + + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) + else + kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) + end if + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between rhizosphere shells + + do jpath = n_hypool_ag+3,n_hpool_tot-1 + + i_dn = jpath + i_up = jpath+1 + ishell_dn = i_dn - (n_hypool_ag+2) + ishell_up = i_up - (n_hypool_ag+2) + kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) + kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + end do + + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- + + tris_a(1) = 0._r8 + tris_b(1) = A_term(1) - denh20*vol_node(1)/dt_substep + tris_c(1) = B_term(1) + tris_r(1) = q_top - k_eff(1)*(h_node(2)-h_node(1)) + + + do inode = 2,n_hypool_tot-1 + jpath = inode + tris_a(inode) = -A_term(jpath-1) + tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_c(inode) = B_term(jpath) + tris_r(inode) = -k_eff(jpath)*(h_node(inode+1)-h_node(inode)) + & + k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + + end do + + inode = n_hypool_tot + jpath = n_hypool_tot + tris_a(inode) = -A_term(jpath-1) + tris_b(inode) = -B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_c(inode) = 0._r8 + tris_r(inode) = k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + + + ! Calculate the change in theta + + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) + + + ! Catch super-saturated and sub-residual water contents + + ! Mass error (flux - change) + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_end = sum((th_node(:)+dth_node(:))*v_node(:))*denh2o + + wb_step_err = (q_top*dt_substep) - (w_tot_beg-w_tot_end) + + if(abs(wb_step_err)>err_thresh)then + solution_found = .false. + exit + else + ! Note: this is somewhat of a default true. And the sub-steps + ! will keep going unless its changed and broken out of + ! the loop. + solution_found = .true. + end if + + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator + + th_node(:) = th_node(:) + dth_node(:) + + ! Accumulate the water balance error for diagnostic purposes + wb_err = wb_err + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + inode = n_hypool_ag + sapflow = sapflow + dt_substep * & + (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) + A_term(inode)*dth_node(inode) + & ! dq at node i + B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + inode = h_hypool_ag+2 + rootuptake = rootuptake + dt_substep * & + (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) + A_term(inode)*dth_node(inode) + & ! dq at node i + B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + + + end do ! do istep = 1,nsteps (substep loop) - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + iterh1=iterh1+1 end do - - - ! Path is between lowest stem and transporting root - - jpath = n_hypool_ag - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) - kmax_lo = cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - ! Path is between the absorbing root and the first - ! rhizosphere - - jpath = n_hypool_ag+1 - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes + ! If we have made it to this point, supposedly we have completed the whole time-step + ! for this cohort x layer combination. It is now safe to save the delta theta + ! value and pass it back to the calling routine. The value passed back is the + ! change in theta over all sub-steps. - jpath = n_hypool_ag+2 - i_dn = jpath - i_up = jpath+1 - - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then - kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) - else - kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) - end if - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) + dth_node(:) = th_node(:)-th_node_init(:) - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between rhizosphere shells - - do jpath = n_hypool_ag+3,n_hpool_tot-1 - - i_dn = jpath - i_up = jpath+1 - ishell_dn = i_dn - (n_hypool_ag+2) - ishell_up = i_up - (n_hypool_ag+2) - kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) - kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - end do - - ! ------------------------------------------------------------------------------- - ! Part 3. - ! Loop through nodes again, build matrix - ! ------------------------------------------------------------------------------- - - do inode = 1,n_hypool_tot - a(inode) - b(inode) - c(inode) - r(inode) - end do - return diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ce71dc61dc..057c1f26f3 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -118,7 +118,7 @@ module FatesPlantHydraulicsMod ! hydraulic properties and states be ! updated every day when trees grow or ! when recruitment happens? - logical,parameter :: debug = .false. !flag to report warning in hydro + logical,parameter :: debug = .true. !flag to report warning in hydro character(len=*), parameter, private :: sourcefile = & @@ -2427,6 +2427,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft ncoh_col = ncoh_col + 1 + ccohort_hydr%qtop_dt = 0._r8 ccohort_hydr%dqtopdth_dthdt = 0._r8 ccohort_hydr%sapflow = 0._r8 @@ -2443,9 +2444,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) qflx_tran_veg_indiv = 0._r8 end if - ! Calculate the maximum conductivity of the root-rhizosphere interface - ! which is dependent on the flow gradient. - call KmaxInnerShell(sites(s),ccohort, bc_in(s)%hksat_sisl(:), ccohort_hydr%kmax_innershell(:)) ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS ! _____ @@ -2473,14 +2471,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! |_____| | | k-1 | k | k+1 | !--------------------------------------------------------------------------- - ! Set node heights of the leaf, stem and transporting roots - z_node_1l(1:n_hypool_ag) = ccohort_hydr%z_node_ag(:) ! leaf and stem - z_node_1l(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) = ccohort_hydr%z_node_troot(:) - - v_node_1l(1:n_hypool_ag) = ccohort_hydr%v_ag(:) - v_node_1l(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) = ccohort_hydr%v_troot(:) - - ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, ! each of which encompass all plant nodes and soil nodes for a given soil layer j, ! with the timestep fraction for each layer-specific solution proportional to each @@ -2495,99 +2485,52 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! root hydraulic redistribution emerges within this sequence when a ! layers have transporting-to-absorbing root water potential gradients of opposite sign - kbg_layer(:) = 0._r8 - kbg_tot = 0._r8 - + + kbg_tot = 0._r8 + do j=1,site_hydr%nlevsoi_hyd - - ! Set node heights of the absorbing root compartment and rhizosphere shells - z_node_1l(n_hypool_ag+n_hypool_troot+1:n_hypool_tot) = bc_in(s)%z_sisl(j) - ! Set the node volume of the absorbing root - v_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%v_aroot_layer(j) - ! Set the node volume of the rhizosphere shells - v_node_1l(n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%v_shell(j,:) * & - ccohort_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j) - - site_hydr%kmax_bound_shell(j,1)=ccohort_hydr%kmax_innershell(j) - site_hydr%kmax_upper_shell(j,1)=ccohort_hydr%kmax_innershell(j) - site_hydr%kmax_lower_shell(j,1)=ccohort_hydr%kmax_innershell(j) - - kmax_bound_1l(:) = 0._r8 - kmax_bound_shell_1l(:) = site_hydr%kmax_bound_shell(j,:) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - - - ! transporting-to-absorbing root max conductance: - ! -------------------------------------------------- - ! factor of 2 means one-half of the total - ! belowground resistance in layer j - kmax_bound_1l((n_hypool_ag+1)) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - ! transporting-to-absorbing root conductance: factor of 2*2 means one-half of the total - ! belowground resistance in layer j, split in half between transporting and absorbing root - kmax_lower_1l(n_hypool_ag+1) = 4._r8 * ccohort_hydr%kmax_treebg_layer(j) - - - ! radial absorbing root conductance: factor of 2 means one-half of the - ! total belowground resistance in layer j - kmax_bound_aroot_soil1 = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - - ! (root surface)-to-(soil shell#1) conductance - kmax_bound_aroot_soil2 = kmax_bound_shell_1l(1) - - ! combined (soil shell#1)-to-(absorbing root) conductance - ! ------------------------------------------------------- - kmax_bound_1l(n_hypool_ag+2) = 1._r8/(1._r8/kmax_bound_aroot_soil1 + & - 1._r8/kmax_bound_aroot_soil2) - - kmax_upper_1l(n_hypool_ag+2) = kmax_lower_1l(n_hypool_ag+1) - kmax_lower_1l(n_hypool_ag+2) = 2._r8 * ccohort_hydr%kmax_treebg_layer(j) - - ! REMEMBER: kmax_bound_shell_1l defined at the uppper (closer to atmosphere) - ! boundary for each node, while kmax_bound_1l defined at the lower - ! (closer to bulk soil) boundary for each node - kmax_bound_1l(n_hypool_tot-nshell+1:n_hypool_tot-1) = kmax_bound_shell_1l(2:nshell) - kmax_upper_1l(n_hypool_tot-nshell+1:n_hypool_tot) = & - site_hydr%kmax_upper_shell(j,1:nshell) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - - kmax_lower_1l(n_hypool_tot-nshell+1:n_hypool_tot) = site_hydr%kmax_lower_shell(j,1:nshell) * & - ccohort_hydr%l_aroot_layer(j) / site_hydr%l_aroot_layer(j) - th_node_1l(n_hypool_ag+n_hypool_troot+1) = ccohort_hydr%th_aroot(j) - - th_node_1l(n_hypool_ag+n_hypool_troot+2:n_hypool_tot) = & - site_hydr%h2osoi_liqvol_shell(j,1:nshell) + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + kmax_up = cohort_hydr%kmax_aroot_radial_in(j) + else + kmax_up = cohort_hydr%kmax_aroot_radial_out(j) + end if - psi_node_1l( :) = fates_huge - flc_node_1l( :) = fates_huge - dflcdpsi_node_1l(:) = fates_huge - do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - call psi_from_th(ft, porous_media(k), th_node_1l(k), & - psi_node_1l(k),site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(k), psi_node_1l(k), & - flc_node_1l(k), site_hydr, bc_in(s)) - call dflcdpsi_from_psi(ft, porous_media(k), psi_node_1l(k), & - dflcdpsi_node_1l(k), site_hydr, bc_in(s)) - enddo - hdiff_bound_1l( :) = fates_huge - k_bound_1l( :) = fates_huge - dhdiffdpsi0_1l( :) = fates_huge - dhdiffdpsi1_1l( :) = fates_huge - dkbounddpsi0_1l( :) = fates_huge - dkbounddpsi1_1l( :) = fates_huge + ! Get matric potential [Mpa] of the absorbing root + call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+2), & + ccohort_hyd%th_aroot(j), psi_aroot, site_hydr, bc_in) - ! Get k_bound_1l - ! THIS SHOULD ONLY BE CALLING A SUBSET OF THE FOLLOWING ROUTINE? + ! Get Fraction of Total Conductivity [-] of the absorbing root + call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+2), & + psi_aroot, ftc_aroot, site_hydr, bc_in) + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + ! from absorbing root node to 1st rhizosphere shell + r_shells = 1._r8/(kmax_aroot*ftc_aroot) - call boundary_hdiff_and_k(1, z_node_1l(pick_1l), psi_node_1l(pick_1l), & - flc_node_1l(pick_1l), dflcdpsi_node_1l(pick_1l), & - kmax_bound_1l(pick_1l), kmax_upper_1l(pick_1l), & - kmax_lower_1l(pick_1l), hdiff_bound_1l, k_bound_1l, dhdiffdpsi0_1l, & - dhdiffdpsi1_1l, dkbounddpsi0_1l, dkbounddpsi1_1l, & - kmax_bound_aroot_soil1, kmax_bound_aroot_soil2) + ! Path is between rhizosphere shells + + do i = 1,nshell + + kmax_up = site_hydr%kmax_outer_shell(j,i) + kmax_lo = site_hydr%kmax_inner_shell(j,i) + + call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+3), & + site_hydr%h2osoi_liqvol_shell(j,i), psi_shell, site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+3), & + psi_shell, ftc_shell, site_hydr, bc_in) + + r_shells = r_shells + 1._r8/(kmax_lo*ftc_shell) + if(i allowable_rel_err)then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + end if + + end do + end if + + + end subroutine Hydraulics_Tridiagonal !-------------------------------------------------------------------------------! diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 13412c4d3f..97c80d5eaf 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -280,8 +280,6 @@ module FatesHydraulicsMemMod real(r8),allocatable :: errh2o_pheno_aroot(:) ! same as errh2o_pheno_ag but for aroot pools ! BC PLANT HYDRAULICS - fluxes - real(r8) :: qtop_dt ! transpiration boundary condition (+ to atm) [kg/indiv/timestep] - real(r8) :: dqtopdth_dthdt ! transpiration tendency term (+ to atm) [kg/indiv/timestep] ! NOTE: total transpiration is given by qtop_dt + dqtopdth_dthdt real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] real(r8) :: rootuptake ! net flow into roots (+ into roots) [kg/indiv/timestep] From 45a221c08376df3a01832191d1dcbe40e969258d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 29 Aug 2019 18:09:25 -0700 Subject: [PATCH 009/114] More refactors to hydro, mostly pruning out unused variables --- biogeophys/FatesHydroSolversMod.F90 | 94 +++- biogeophys/FatesPlantHydraulicsMod.F90 | 659 +++++++++---------------- main/FatesHistoryInterfaceMod.F90 | 207 +------- main/FatesHydraulicsMemMod.F90 | 166 +++---- 4 files changed, 387 insertions(+), 739 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index 1b16fbcae6..e9e92a0e18 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -81,7 +81,7 @@ subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! is regulated completely by the stem conductance from the stem's ! center of storage, to the petiole. - ccohort_hydr%kmax_petiole_to_leaf = 1.e12_r8 + ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 ! Stem Maximum Hydraulic Conductance @@ -237,17 +237,13 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, type(ed_site_hydr_type), intent(in),target :: site_hydr integer , intent(in) :: ilayer ! soil layer index of interest real(r8) , intent(in) :: psi_node(:) ! matric potential of nodes [Mpa] - real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] + real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] real(r8) , intent(in) :: dt_step ! time [seconds] over-which to calculate solution real(r8) , intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] real(r8),intent(out) :: d_th_node(n_hypool_tot) ! change in theta over the timestep real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] real(r8),intent(out) :: wb_err ! transpiration should match change in storage [kg] - - - - ! Locals @@ -256,10 +252,16 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, integer :: ishell ! rhizosphere shell index of the node integer :: i_dn ! downstream node of current flow-path integer :: i_up ! upstream node of current flow-path + integer :: iter ! iteration count for sub-steps + logical :: solution_found ! logical set to true if a solution was found within error tolerance real(r8) :: kmax_up ! maximum conductance of the upstream half of path [kg s-1 Mpa-1] real(r8) :: kmax_dn ! maximum conductance of the downstream half of path [kg s-1 MPa-1] real(r8) :: wb_step_err - real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] + real(r8) :: wb_err ! sum of water balance error over substeps + real(r8) :: leaf_water ! kg of water in the leaf + real(r8) :: stem_water ! kg of water in the stem + real(r8) :: root_water ! kg of water in the transp and absorbing roots + real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] real(r8) :: th_node(n_hypool_tot) real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] real(r8) :: v_node(n_hypool_tot) ! volume of the node [m3] @@ -276,6 +278,9 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_r(n_hypool_tot) + integer, parameter :: max_iter = 5 + real(r8), parameter :: max_wb_step_err = 1.e-6_r8 + real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] ! ------------------------------------------------------------------------------- ! Part 1. Calculate node quantities: @@ -299,8 +304,8 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, th_node_init(inode) = ccohort_hydr%th_ag(inode) elseif (inode==n_hypool_ag+1) then z_node(inode) = ccohort_hydr%z_node_troot - v_node(inode) = ccohort_hydr%v_troot(1) - th_node_init(inode) = ccohort_hydr%th_troot(1) + v_node(inode) = ccohort_hydr%v_troot + th_node_init(inode) = ccohort_hydr%th_troot elseif (inode==n_hyppol_ag+2) then z_node(inode) = bc_in(s)%z_sisl(ilayer) v_node(inode) = ccohort_hydr%v_aroot_layer(:) @@ -332,7 +337,7 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, rootuptake = 0._r8 wb_err = 0._r8 - ! Gracefully quit if this is not going so well + ! Gracefully quit if too many iterations have been used if(iter>max_iter)then write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' write(fates_log(),*) '' @@ -340,10 +345,8 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - - root_water = (sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o - + root_water = (ccohort_hydr%th_troot*ccohort_hydr%v_troot) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' write(fates_log(),*) 'root_water: ',root_water,' kg/plant' @@ -463,8 +466,8 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, B_term(jpath)) - ! Path is between the absorbing root and the first - ! rhizosphere + ! Path is between the transporting root + ! and the absorbing root for this layer jpath = n_hypool_ag+1 i_dn = jpath @@ -574,7 +577,7 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, wb_step_err = (q_top*dt_substep) - (w_tot_beg-w_tot_end) - if(abs(wb_step_err)>err_thresh)then + if(abs(wb_step_err)>max_wb_step_err)then solution_found = .false. exit else @@ -623,7 +626,64 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, iterh1=iterh1+1 end do + + ! Save the number of times we refined our sub-step counts (iterh1) + ccohort_hydr%iterh1 = real(iterh1) + ! Save the number of sub-steps we ultimately used + ccohort_hydr%iterh2 = real(nsteps) + + ! ----------------------------------------------------------- + ! To a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err) > max_wb_err ) then + + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err + write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' + + leaf_water = ccohort_hydr%th_ag(1)*ccohort_hydr%v_ag(1)*denh2o + stem_water = sum(ccohort_hydr%th_ag(2:n_hypool_ag) * & + ccohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',ccohort%dbh + write(fates_log(),*) 'pft: ',ccohort%pft + write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Adjust final water balance by adding back in the error term + ! ------------------------------------------------------------ + w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg + dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep + we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep + we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual + if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then + if(debug) then + write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' + endif + !dump the error water to the bin with largest water storage + max_l = maxloc(th_node(:)*v_node(:),dim=1) + th_node(max_l) = th_node(max_l)- & + we_tot_outer/(v_node(max_l)*denh2o) + th_node(max_l) = min (th_node(max_l),& + ths_node(max_l)-small_theta_num) + th_node(max_l) = max(th_node(max_l),& + thr_node(max_l)+small_theta_num) + w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg + dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep + we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep + we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual + end if + + + ! If we have made it to this point, supposedly we have completed the whole time-step ! for this cohort x layer combination. It is now safe to save the delta theta ! value and pass it back to the calling routine. The value passed back is the diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 057c1f26f3..321b3aa788 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -249,20 +249,6 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! equal to the ones we just calculated. call SavePreviousCompartmentVolumes(ccohort_hydr) - ! Set some generic initial values - ccohort_hydr%refill_days = 3.0_r8 - ccohort_hydr%lwp_mem(:) = 0.0_r8 - ccohort_hydr%lwp_stable = 0.0_r8 - ccohort_hydr%lwp_is_unstable = .false. - ccohort_hydr%flc_ag(:) = 1.0_r8 - ccohort_hydr%flc_troot(:) = 1.0_r8 - ccohort_hydr%flc_aroot(:) = 1.0_r8 - ccohort_hydr%flc_min_ag(:) = 1.0_r8 - ccohort_hydr%flc_min_troot(:) = 1.0_r8 - ccohort_hydr%flc_min_aroot(:) = 1.0_r8 - ccohort_hydr%refill_thresh = -0.01_r8 - ccohort_hydr%refill_days = 3.0_r8 - ccohort => ccohort%taller enddo @@ -343,17 +329,17 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !be in (or at least close to) hydrostatic equilibrium as well, so that !it doesn't matter which absorbing root layer the transporting root water !potential is referenced to. - do k=1, n_hypool_troot - dz = ccohort_hydr%z_node_troot(k) - ccohort_hydr%z_node_aroot(1) - ccohort_hydr%psi_troot(k) = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz - if (ccohort_hydr%psi_troot(k)>0.0_r8) ccohort_hydr%psi_troot(k) = -0.01_r8 - call th_from_psi(ft, 3, ccohort_hydr%psi_troot(k), ccohort_hydr%th_troot(k), csite%si_hydr, bc_in) - end do + + dz = ccohort_hydr%z_node_troot - ccohort_hydr%z_node_aroot(1) + ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz + if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 + call th_from_psi(ft, 3, ccohort_hydr%psi_troot, ccohort_hydr%th_troot, csite%si_hydr, bc_in) + !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below - dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot(1) - ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot(1) - 1.e-6_r8*denh2o*grav_earth*dz + dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot + ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 call th_from_psi(ft, 2, ccohort_hydr%psi_ag(n_hypool_ag), ccohort_hydr%th_ag(n_hypool_ag), csite%si_hydr, bc_in) do k=n_hypool_ag-1, 1, -1 @@ -363,25 +349,12 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), ccohort_hydr%th_ag(k), csite%si_hydr, bc_in) end do - ccohort_hydr%lwp_mem(:) = ccohort_hydr%psi_ag(1) ! initializes the leaf water potential memory - ccohort_hydr%lwp_stable = ccohort_hydr%psi_ag(1) - ccohort_hydr%lwp_is_unstable = .false. ! inital value for leaf water potential stability flag - ccohort_hydr%flc_ag(:) = 1.0_r8 - ccohort_hydr%flc_troot(:) = 1.0_r8 - ccohort_hydr%flc_aroot(:) = 1.0_r8 - ccohort_hydr%flc_min_ag(:) = 1.0_r8 - ccohort_hydr%flc_min_troot(:) = 1.0_r8 - ccohort_hydr%flc_min_aroot(:) = 1.0_r8 - ccohort_hydr%refill_thresh = -0.01_r8 - ccohort_hydr%refill_days = 3.0_r8 ccohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 - ccohort_hydr%errh2o_growturn_troot(:) = 0.0_r8 - ccohort_hydr%errh2o_growturn_aroot(:) = 0.0_r8 + ccohort_hydr%errh2o_growturn_troot = 0.0_r8 + ccohort_hydr%errh2o_growturn_aroot = 0.0_r8 ccohort_hydr%errh2o_pheno_ag(:) = 0.0_r8 - ccohort_hydr%errh2o_pheno_troot(:) = 0.0_r8 - ccohort_hydr%errh2o_pheno_aroot(:) = 0.0_r8 - !ccohort_hydr%th_aroot_prev(:) = 0.0_r8 - !ccohort_hydr%th_aroot_prev_ucnorr(:)= 0.0_r8 + ccohort_hydr%errh2o_pheno_troot = 0.0_r8 + ccohort_hydr%errh2o_pheno_aroot = 0.0_r8 !initialize cohort-level btran call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) @@ -404,9 +377,9 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) ! Outputs: cohort_hydr%z_node_ag(:) ! %z_lower_ag(:) ! %z_upper_ag(:) - ! %z_node_troot(:) - ! %z_lower_troot(:) - ! %z_upper_troot(:) + ! %z_node_troot + ! %z_lower_troot + ! %z_upper_troot ! %z_node_aroot(:) ! -------------------------------------------------------------------------------- @@ -485,7 +458,7 @@ subroutine SavePreviousCompartmentVolumes(ccohort_hydr) ! change size and effect water contents ccohort_hydr%v_ag_init(:) = ccohort_hydr%v_ag(:) - ccohort_hydr%v_troot_init(:) = ccohort_hydr%v_troot(:) + ccohort_hydr%v_troot_init = ccohort_hydr%v_troot ccohort_hydr%v_aroot_layer_init(:) = ccohort_hydr%v_aroot_layer(:) return @@ -616,6 +589,8 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) real(r8) :: z_stem ! the height of the plants stem below crown [m] real(r8) :: sla ! specific leaf area [cm2/g] real(r8) :: v_canopy ! total leaf (canopy) volume [m3/indiv] + real(r8) :: v_aroot_tot ! total compartment volume of all absorbing roots for cohort [m3] + real(r8) :: l_aroot_tot ! total length of absorbing roots for cohrot [m] real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] real(r8) :: a_sapwood ! sapwood area [m2] real(r8) :: a_sapwood_target ! sapwood cross-section area at reference height, at target biomass [m2] @@ -707,17 +682,17 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8) !! BOC not sure if/how we should multiply this by the sapwood fraction - ccohort_hydr%v_troot(:) = v_troot / n_hypool_troot + ccohort_hydr%v_troot = v_troot / n_hypool_troot ! Estimate absorbing root total length (all layers) ! ------------------------------------------------------------------------------ - ccohort_hydr%l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(ft) ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ - ccohort_hydr%v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & - ccohort_hydr%l_aroot_tot + v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & + l_aroot_tot ! Partition the total absorbing root lengths and volumes into the active soil layers @@ -729,8 +704,8 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) end if - ccohort_hydr%l_aroot_layer(j) = rootfr*ccohort_hydr%l_aroot_tot - ccohort_hydr%v_aroot_layer(j) = rootfr*ccohort_hydr%v_aroot_tot + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot + ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot end do end if !check for bleaf @@ -879,7 +854,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) integer :: j,k,FT ! indices integer :: err_code = 0 real(r8) :: th_ag_uncorr( n_hypool_ag) ! uncorrected aboveground water content[m3 m-3] - real(r8) :: th_troot_uncorr(n_hypool_troot) ! uncorrected transporting root water content[m3 m-3] + real(r8) :: th_troot_uncorr ! uncorrected transporting root water content[m3 m-3] real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevsoi_hyd) ! uncorrected absorbing root water content[m3 m-3] real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] integer :: nstep !number of time steps @@ -898,28 +873,33 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, k) enddo - do k=1,n_hypool_troot - th_troot_uncorr(k) = ccohort_hydr%th_troot(k) * & - ccohort_hydr%v_troot_init(k) /ccohort_hydr%v_troot(k) - ccohort_hydr%th_troot(k) = constrain_water_contents(th_troot_uncorr(k), small_theta_num, ft, 3) - enddo + + th_troot_uncorr = ccohort_hydr%th_troot * ccohort_hydr%v_troot_init /ccohort_hydr%v_troot + ccohort_hydr%th_troot = constrain_water_contents(th_troot_uncorr, small_theta_num, ft, 3) + + + ccohort_hydr%errh2o_growturn_aroot = 0._r8 do j=1,currentSite%si_hydr%nlevsoi_hyd - th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & - ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) - ccohort_hydr%errh2o_growturn_aroot(j) = ccohort_hydr%th_aroot(j) - th_aroot_uncorr(j) + th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & + ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) + ccohort_hydr%errh2o_growturn_aroot = ccohort_hydr%errh2o_growturn_aroot + & + denh2o*cCohort%n/AREA*(ccohort_hydr%th_aroot(j)-th_aroot_uncorr(j))*ccohort_hydr%v_aroot_layer(j) enddo ! Storing mass balance error ! + means water created; - means water destroyed - ccohort_hydr%errh2o_growturn_ag(:) = ccohort_hydr%th_ag(:) - th_ag_uncorr(:) - ccohort_hydr%errh2o_growturn_troot(:) = ccohort_hydr%th_troot(:) - th_troot_uncorr(:) + ccohort_hydr%errh2o_growturn_ag(:) = denh2o*cCohort%n/AREA*ccohort_hydr%v_ag(:) * & + (ccohort_hydr%th_ag(:)-th_ag_uncorr(:)) + ccohort_hydr%errh2o_growturn_troot = denh2o*cCohort%n/AREA*ccohort_hydr%v_troot * & + (ccohort_hydr%th_troot-th_troot_uncorr) + csite_hydr =>currentSite%si_hydr csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & - (sum(ccohort_hydr%errh2o_growturn_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%errh2o_growturn_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%errh2o_growturn_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*cCohort%n/AREA + sum(ccohort_hydr%errh2o_growturn_ag(:)) + & + ccohort_hydr%errh2o_growturn_troot + & + ccohort_hydr%errh2o_growturn_aroot + ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 @@ -983,8 +963,6 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%v_ag = ocohort_hydr%v_ag ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init ncohort_hydr%v_troot = ocohort_hydr%v_troot - ncohort_hydr%v_aroot_tot = ocohort_hydr%v_aroot_tot - ncohort_hydr%l_aroot_tot = ocohort_hydr%l_aroot_tot ! quantities indexed by soil layer ncohort_hydr%z_node_aroot = ocohort_hydr%z_node_aroot ncohort_hydr%kmax_treebg_layer = ocohort_hydr%kmax_treebg_layer @@ -998,32 +976,13 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%th_troot = ocohort_hydr%th_troot ncohort_hydr%psi_ag = ocohort_hydr%psi_ag ncohort_hydr%psi_troot = ocohort_hydr%psi_troot - ncohort_hydr%flc_ag = ocohort_hydr%flc_ag - ncohort_hydr%flc_troot = ocohort_hydr%flc_troot - ncohort_hydr%flc_min_ag = ocohort_hydr%flc_min_ag - - ncohort_hydr%flc_min_troot = ocohort_hydr%flc_min_troot - !refilling status--these are constants are should be moved the fates parameter file(Chonggang XU) - ncohort_hydr%refill_thresh = ocohort_hydr%refill_thresh - ncohort_hydr%refill_days = ocohort_hydr%refill_days ncohort_hydr%btran = ocohort_hydr%btran - - ncohort_hydr%lwp_mem = ocohort_hydr%lwp_mem - ncohort_hydr%lwp_stable = ocohort_hydr%lwp_stable - ncohort_hydr%lwp_is_unstable = ocohort_hydr%lwp_is_unstable ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag - ncohort_hydr%iterh1 = ocohort_hydr%iterh1 ncohort_hydr%iterh2 = ocohort_hydr%iterh2 ncohort_hydr%errh2o = ocohort_hydr%errh2o ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag - - - - - - ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag @@ -1032,11 +991,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot ! quantities indexed by soil layer ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - !ncohort_hydr%th_aroot_prev = ocohort_hydr%th_aroot_prev - !ncohort_hydr%th_aroot_prev_uncorr = ocohort_hydr%th_aroot_prev_uncorr ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%flc_aroot = ocohort_hydr%flc_aroot - ncohort_hydr%flc_min_aroot = ocohort_hydr%flc_min_aroot ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot @@ -1047,16 +1002,6 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%sapflow = ocohort_hydr%sapflow ncohort_hydr%rootuptake = ocohort_hydr%rootuptake - ncohort_hydr%rootuptake01 = ocohort_hydr%rootuptake01 - ncohort_hydr%rootuptake02 = ocohort_hydr%rootuptake02 - ncohort_hydr%rootuptake03 = ocohort_hydr%rootuptake03 - ncohort_hydr%rootuptake04 = ocohort_hydr%rootuptake04 - ncohort_hydr%rootuptake05 = ocohort_hydr%rootuptake05 - ncohort_hydr%rootuptake06 = ocohort_hydr%rootuptake06 - ncohort_hydr%rootuptake07 = ocohort_hydr%rootuptake07 - ncohort_hydr%rootuptake08 = ocohort_hydr%rootuptake08 - ncohort_hydr%rootuptake09 = ocohort_hydr%rootuptake09 - ncohort_hydr%rootuptake10 = ocohort_hydr%rootuptake10 ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited @@ -1086,8 +1031,8 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%th_ag(:) = (currentCohort%n*ccohort_hydr%th_ag(:) + & nextCohort%n*ncohort_hydr%th_ag(:))/newn - ccohort_hydr%th_troot(:) = (currentCohort%n*ccohort_hydr%th_troot(:) + & - nextCohort%n*ncohort_hydr%th_troot(:))/newn + ccohort_hydr%th_troot = (currentCohort%n*ccohort_hydr%th_troot + & + nextCohort%n*ncohort_hydr%th_troot)/newn ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & nextCohort%n*ncohort_hydr%th_aroot(:))/newn ccohort_hydr%supsub_flag = 0._r8 @@ -1100,61 +1045,20 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & ccohort_hydr%flc_ag(k), site_hydr, bc_in) end do - do k=n_hypool_ag+1,n_hypool_ag+n_hypool_troot - call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot(k-n_hypool_ag), & - ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, 3, ccohort_hydr%psi_troot(k-n_hypool_ag), & - ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in) - end do + + call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot, & + ccohort_hydr%psi_troot, site_hydr, bc_in) + do j=1,site_hydr%nlevsoi_hyd call psi_from_th(currentCohort%pft, 4, ccohort_hydr%th_aroot(j), & ccohort_hydr%psi_aroot(j), site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, 4, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%flc_aroot(j), site_hydr, bc_in) end do call flc_gs_from_psi(currentCohort, ccohort_hydr%psi_ag(1)) - ccohort_hydr%qtop_dt = (currentCohort%n*ccohort_hydr%qtop_dt + & - nextCohort%n*ncohort_hydr%qtop_dt)/newn - ccohort_hydr%dqtopdth_dthdt = (currentCohort%n*ccohort_hydr%dqtopdth_dthdt + & - nextCohort%n*ncohort_hydr%dqtopdth_dthdt)/newn + ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & nextCohort%n*ncohort_hydr%sapflow)/newn ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & nextCohort%n*ncohort_hydr%rootuptake)/newn - ccohort_hydr%rootuptake01 = (currentCohort%n*ccohort_hydr%rootuptake01 + & - nextCohort%n*ncohort_hydr%rootuptake01)/newn - ccohort_hydr%rootuptake02 = (currentCohort%n*ccohort_hydr%rootuptake02 + & - nextCohort%n*ncohort_hydr%rootuptake02)/newn - ccohort_hydr%rootuptake03 = (currentCohort%n*ccohort_hydr%rootuptake03 + & - nextCohort%n*ncohort_hydr%rootuptake03)/newn - ccohort_hydr%rootuptake04 = (currentCohort%n*ccohort_hydr%rootuptake04 + & - nextCohort%n*ncohort_hydr%rootuptake04)/newn - ccohort_hydr%rootuptake05 = (currentCohort%n*ccohort_hydr%rootuptake05 + & - nextCohort%n*ncohort_hydr%rootuptake05)/newn - ccohort_hydr%rootuptake06 = (currentCohort%n*ccohort_hydr%rootuptake06 + & - nextCohort%n*ncohort_hydr%rootuptake06)/newn - ccohort_hydr%rootuptake07 = (currentCohort%n*ccohort_hydr%rootuptake07 + & - nextCohort%n*ncohort_hydr%rootuptake07)/newn - ccohort_hydr%rootuptake08 = (currentCohort%n*ccohort_hydr%rootuptake08 + & - nextCohort%n*ncohort_hydr%rootuptake08)/newn - ccohort_hydr%rootuptake09 = (currentCohort%n*ccohort_hydr%rootuptake09 + & - nextCohort%n*ncohort_hydr%rootuptake09)/newn - ccohort_hydr%rootuptake10 = (currentCohort%n*ccohort_hydr%rootuptake10 + & - nextCohort%n*ncohort_hydr%rootuptake10)/newn - - ccohort_hydr%lwp_mem(:) = ccohort_hydr%psi_ag(1) - ccohort_hydr%lwp_stable = ccohort_hydr%psi_ag(1) - ccohort_hydr%lwp_is_unstable = .false. - ccohort_hydr%flc_min_ag(:) = (currentCohort%n*ccohort_hydr%flc_min_ag(:) + & - nextCohort%n*ncohort_hydr%flc_min_ag(:))/newn - ccohort_hydr%flc_min_troot(:) = (currentCohort%n*ccohort_hydr%flc_min_troot(:) + & - nextCohort%n*ncohort_hydr%flc_min_troot(:))/newn - ccohort_hydr%flc_min_aroot(:) = (currentCohort%n*ccohort_hydr%flc_min_aroot(:) + & - nextCohort%n*ncohort_hydr%flc_min_aroot(:))/newn - - ! need to be migrated to parmeter file (BOC 07/24/2018) - ccohort_hydr%refill_thresh = -0.01_r8 - ccohort_hydr%refill_days = 3.0_r8 ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & nextCohort%n*ncohort_hydr%errh2o)/newn @@ -1166,13 +1070,10 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne nextCohort%n*ncohort_hydr%errh2o_growturn_troot(:))/newn ccohort_hydr%errh2o_pheno_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot(:) + & nextCohort%n*ncohort_hydr%errh2o_pheno_troot(:))/newn - ccohort_hydr%errh2o_growturn_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_aroot(:))/newn - ccohort_hydr%errh2o_pheno_aroot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_aroot(:))/newn - - !ccohort_hydr%th_aroot_prev(:) - !ccohort_hydr%th_aroot_prev_uncorr(:) + ccohort_hydr%errh2o_growturn_aroot = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot + & + nextCohort%n*ncohort_hydr%errh2o_growturn_aroot)/newn + ccohort_hydr%errh2o_pheno_aroot = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot + & + nextCohort%n*ncohort_hydr%errh2o_pheno_aroot)/newn ccohort_hydr%is_newly_recruited = .false. @@ -1317,21 +1218,14 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) ! ! init_patch() -> updateSizeDepRhizHydProps -> shellgeom() ! this%v_shell - ! this%v_shell_1D ! this%r_node_shell ! this%r_out_shell - ! this%r_out_shell_1D - ! this%r_node_shell_1D ! ! init_patch() -> updateSizeDepRhizHydProps() ! this%l_aroot_layer_init ! this%l_aroot_1D ! this%kmax_upper_shell - ! this%kmax_bound_shell ! this%kmax_lower_shell - ! this%kmax_upper_shell_1D - ! this%kmax_bound_shell_1D - ! this%kmax_lower_shell_1D ! ! hydraulics_bc() ! this%supsub_flag @@ -1667,8 +1561,6 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) cPatch => cPatch%older enddo !patch - csite_hydr%l_aroot_1D = sum( csite_hydr%l_aroot_layer(:)) - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) do j = 1,nlevsoi_hyd ! proceed only if l_aroot_coh has changed @@ -1678,8 +1570,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) end if !has l_aroot_layer changed? enddo - call shellGeom( csite_hydr%l_aroot_1D, csite_hydr%rs1(1), AREA, sum(bc_in%dz_sisl(1:nlevsoi_hyd)), & - csite_hydr%r_out_shell_1D(:), csite_hydr%r_node_shell_1D(:), csite_hydr%v_shell_1D(:)) + !update the conductitivity for first soil shell is done at subroutine KmaxInnerShell !which is dependant on whether it is water uptake or loss for every 30 minutes @@ -1712,19 +1603,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - csite_hydr%kmax_bound_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_node_shell(j,k-1))*hksat_s - csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s - if(j == 1) then - csite_hydr%kmax_upper_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_out_shell_1D(k-1))*hksat_s - csite_hydr%kmax_bound_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_node_shell_1D(k)/csite_hydr%r_node_shell_1D(k-1))*hksat_s - csite_hydr%kmax_lower_shell_1D(k) = 2._r8*pi_const*csite_hydr%l_aroot_1D / & - log(csite_hydr%r_out_shell_1D( k)/csite_hydr%r_node_shell_1D(k ))*hksat_s - end if enddo ! loop over rhizosphere shells end if !has l_aroot_layer changed? enddo ! loop over soil layers @@ -2019,7 +1899,7 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) ccohort=>cpatch%tallest do while(associated(ccohort)) bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & - ccohort%co_hydr%btran(1) * & + ccohort%co_hydr%btran * & (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & @@ -2247,61 +2127,24 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] ! cohort-specific arrays to hold 1D hydraulics geometric & state variables for entire continuum (leaf,stem,root,soil) - real(r8) :: z_node_1l( n_hypool_tot) ! nodal height of water storage compartments (single-layer soln) [m] - real(r8) :: v_node_1l( n_hypool_tot) ! volume of water storage compartments (single-layer soln) [m3] - real(r8) :: psi_node( n_hypool_tot) ! water potential in water storage compartments [MPa] - real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] - real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] - real(r8) :: flc_min_node( n_hypool_tot-nshell)! minimum attained fractional loss of conductivity (for xylem refilling dynamics) [-] - real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] - real(r8) :: ths_node( n_hypool_tot) ! saturated volumetric water in water storage compartments [m3 m-3] - real(r8) :: ths_node_1l( n_hypool_tot) ! saturated volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: thr_node( n_hypool_tot) ! residual volumetric water in water storage compartments [m3 m-3] - real(r8) :: thr_node_1l( n_hypool_tot) ! residual volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: the_node( n_hypool_tot) ! error resulting from supersaturation or below-residual th_node [m3 m-3] - real(r8) :: the_node_1l( n_hypool_tot) ! like the_node(:) but for specific single soil layer [m3 m-3] - real(r8) :: th_node( n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] - real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: dth_node( n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] - real(r8) :: dth_node_1l( n_hypool_tot) ! like dth_node_1l(:) but for specific single soil layer [m3 m-3] - real(r8) :: kmax_bound( n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] - real(r8) :: kmax_bound_1l(n_hypool_tot) ! lower boundary maximum hydraulic conductance of compartments (single-layer soln) [kg s-1 MPa-1] - real(r8) :: kmax_upper( n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] - real(r8) :: kmax_upper_1l(n_hypool_tot) ! maximum hydraulic conductance from node to upper boundary (single-layer soln) [kg s-1 MPa-1] - real(r8) :: kmax_lower( n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - real(r8) :: kmax_lower_1l(n_hypool_tot) ! maximum hydraulic conductance from node to lower boundary (single-layer soln) [kg s-1 MPa-1] - real(r8) :: hdiff_bound_1l( nshell+1) ! - real(r8) :: k_bound_1l( nshell+1) ! - real(r8) :: dhdiffdpsi0_1l( nshell+1) ! - real(r8) :: dhdiffdpsi1_1l( nshell+1) ! - real(r8) :: dkbounddpsi0_1l(nshell+1) ! - real(r8) :: dkbounddpsi1_1l(nshell+1) ! - real(r8) :: l_aroot_tot_coh ! total length of absorbing roots across all soil layers (cohort) [m] - real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] + + real(r8) :: ths_node(n_hypool_tot) ! saturated volumetric water in water storage compartments [m3 m-3] + real(r8) :: thr_node(n_hypool_tot) ! residual volumetric water in water storage compartments [m3 m-3] + real(r8) :: the_node(n_hypool_tot) ! error resulting from supersaturation or below-residual th_node [m3 m-3] + real(r8) :: th_node(n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] + real(r8) :: dth_node(n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] + real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] + ! column-specific arrays to hold rhizosphere geometric & state variables real(r8) :: h2osoi_liqvol - real(r8) :: dz_tot ! total soil depth (to bottom of bottom layer) [m] - real(r8) :: l_aroot_tot_col ! total length of absorbing roots across all soil layers [m] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] - real(r8) :: ths_shell_1D(nshell) ! saturated water content of rhizosphere compartment [m3 m-3] - real(r8) :: thr_shell_1D(nshell) ! residual water content of rhizosphere compartment [m3 m-3] - real(r8) :: kmax_bound_shell_1l(nshell) ! like kmax_bound_shell_1D(:) but for specific single soil layer [kg s-1 MPa-1] - real(r8) :: psi_node_shell_1D(nshell) ! soil matric potential of rhizosphere compartment [MPa] - real(r8) :: ths_aroot_1D ! saturated water content of 1D representation of fine roots [m3 m-3] - real(r8) :: thr_aroot_1D ! residual water content of 1D representation of fine roots [m3 m-3] - real(r8) :: vtot_aroot_1D ! sum of fine root volume across soil layers [m3] - real(r8) :: psi_node_aroot_1D ! water potential of absorbing root [MPa] ! hydraulics conductances - real(r8) :: kmax_bound_bylayershell(nlevsoi_hyd_max,nshell) ! maximum conductance at shell boundaries in each layer [kg s-1 MPa-1] - real(r8) :: kmax_bound_aroot_soil1 ! maximum radial conductance of absorbing roots [kg s-1 MPa-1] - real(r8) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] - real(r8) :: ksoil_bylayer(nlevsoi_hyd_max) ! total rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: ksoil_tot ! total rhizosphere conductance (over all shells and soil layers [MPa] real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] - real(r8) :: kmax_stem ! maximum whole-stem (above troot to leaf) conductance [kg s-1 MPa-1] + ! hydraulics other integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered @@ -2332,9 +2175,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: tmp real(r8) :: tmp1 real(r8) :: watres_local + real(r8) :: dt_step integer :: pick_1l(nshell+1) = (/(k,k=n_hypool_ag+n_hypool_troot+1,n_hypool_tot,1)/) - real(r8) :: lwpdiff1, lwpdiff2, Rndiff1, Rndiff2, btran_prev - real(r8) :: refill_rate ! rate of xylem refilling [fraction per unit time; s-1] real(r8) :: roota, rootb ! parameters for root distribution [m-1] real(r8) :: rootfr ! root fraction at different soil layers real(r8) :: prev_h2oveg ! previous time step plant water storage (kg/m2) @@ -2344,6 +2186,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: err_code = 0 + logical, parameter :: weight_serial_dt = .false. ! For serial solver (1D), should + ! the fractional time each layer + ! gets, be weighted by conductance? + + ! ---------------------------------------------------------------------------------- ! Important note: We are interested in calculating the total fluxes in and out of the ! site/column. Usually, when we do things like this, we acknowledge that FATES @@ -2428,8 +2275,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ft = ccohort%pft ncoh_col = ncoh_col + 1 - ccohort_hydr%qtop_dt = 0._r8 - ccohort_hydr%dqtopdth_dthdt = 0._r8 ccohort_hydr%sapflow = 0._r8 ccohort_hydr%rootuptake = 0._r8 @@ -2552,10 +2397,19 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! do j=1,nlevsoi_hyd ! replace j with ordered(jj) in order ! to go through soil layers in order of decreasing total root-soil conductance + + do jj=1,site_hydr%nlevsoi_hyd j = ordered(jj) + if(weight_serial_dt)then + dt_step = dtime*kbg_layer(j)/kbg_tot + else + dt_step = dtime/real(site_hydr%nlevsoi_hyd,r8) + end if + + ! This routine will update the theta values for 1 cohort's flow-path ! from leaf to the current soil layer call ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,j,dt_step,qflx_tran_veg_indiv, & @@ -2578,9 +2432,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot(1) + & dth_node(n_hypool_ag+2)*csite_hydr%v_aroot_layer(j))*denh2o - - - + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n/AREA site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n/AREA @@ -2591,221 +2443,119 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area /AREA - ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow ! - ccohort_hydr%rootuptake = ccohort_hydr%rootuptake + rootuptake ! - + ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow + ccohort_hydr%rootuptake(j) = ccohort_hydr%rootuptake(j) + rootuptake - ! CHANGE THIS TO A VICTORIOUS VECTOR + ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL + dth_layershell_col(j,:) = dth_layershell_col(j,:) + & + dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & + ccohort_hydr%l_aroot_layer(j) * & + ccohort%n / site_hydr%l_aroot_layer(j) - SELECT CASE (ordered(jj)) !! select soil layer - CASE (1) - ccohort_hydr%rootuptake01 = rootuptake - CASE (2) - ccohort_hydr%rootuptake02 = rootuptake - CASE (3) - ccohort_hydr%rootuptake03 = rootuptake - CASE (4) - ccohort_hydr%rootuptake04 = rootuptake - CASE (5) - ccohort_hydr%rootuptake05 = rootuptake - CASE (6) - ccohort_hydr%rootuptake06 = rootuptake - CASE (7) - ccohort_hydr%rootuptake07 = rootuptake - CASE (8) - ccohort_hydr%rootuptake08 = rootuptake - CASE (9) - ccohort_hydr%rootuptake09 = rootuptake - CASE (10) - ccohort_hydr%rootuptake10 = rootuptake - CASE DEFAULT - end SELECT - - ! UPDATE WATER CONTENT & POTENTIAL IN AROOT (COHORT-LEVEL) - ccohort_hydr%th_aroot(ordered(jj)) = th_node_1l(n_hypool_ag+n_hypool_troot+1) - call psi_from_th(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & - ccohort_hydr%th_aroot(ordered(jj)), ccohort_hydr%psi_aroot(ordered(jj)), & - site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(n_hypool_ag+n_hypool_troot+1), & - ccohort_hydr%psi_aroot(ordered(jj)), ccohort_hydr%flc_aroot(ordered(jj)), & - site_hydr, bc_in(s)) - - ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL - dth_layershell_col(ordered(jj),:) = dth_layershell_col(ordered(jj),:) + & - dth_node_1l((n_hypool_tot-nshell+1):n_hypool_tot) * & - ccohort_hydr%l_aroot_layer(ordered(jj)) * & - ccohort%n / site_hydr%l_aroot_layer(ordered(jj)) - - enddo !soil layer - end if !nlevsoi_hyd > 1 - - ! UPDATE WATER CONTENT & POTENTIAL IN LEAVES, STEM, AND TROOT (COHORT-LEVEL) - do k=1,n_hypool_ag - if(site_hydr%nlevsoi_hyd == 1) then - ccohort_hydr%th_ag(k) = th_node(k) - else - ccohort_hydr%th_ag(k) = th_node_1l(k) - endif - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k), site_hydr, bc_in(s) ) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%flc_ag(k), site_hydr, bc_in(s) ) - enddo - do k=(n_hypool_ag+1),(n_hypool_ag+n_hypool_troot) - if(site_hydr%nlevsoi_hyd == 1) then - ccohort_hydr%th_troot(k-n_hypool_ag) = th_node(k) - else - ccohort_hydr%th_troot(k-n_hypool_ag) = th_node_1l(k) - endif - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot(k-n_hypool_ag), & - ccohort_hydr%psi_troot(k-n_hypool_ag), site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot(k-n_hypool_ag), & - ccohort_hydr%flc_troot(k-n_hypool_ag), site_hydr, bc_in(s)) - enddo - - ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP - ! first update the leaf water potential memory - do t=2, numLWPmem - ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) - end do - ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) - call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - - refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 - do k=1,n_hypool_ag - ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) - if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling - ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & - (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) - end if - end do - do k=1,n_hypool_troot - ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) - if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling - ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & - (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) - end if - end do - do j=1,site_hydr%nlevsoi_hyd - ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) - if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & - ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling - ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & - (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) - end if - end do + enddo !soil layer - ccohort => ccohort%shorter - enddo !cohort + ! --------------------------------------------------------- + ! Update water potential of plant compartments + ! --------------------------------------------------------- + + ! Above ground + do k=1,n_hypool_ag + call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k), site_hydr, bc_in(s) ) + enddo + ! Update water potential of transporting root compartment + k = n_hpool_ag+1 + call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot, & + ccohort_hydr%psi_troot, site_hydr, bc_in(s)) + ! Update water potential of absorbing root root compartment + do j=1,site_hydr%nlevsoi_hyd + call psi_from_th(ft, porous_media(n_hypool_ag+2), & + ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j), & + site_hydr, bc_in(s)) + end do + + ccohort => ccohort%shorter + enddo !cohort + + cpatch => cpatch%younger + enddo !patch - cpatch => cpatch%younger - enddo !patch - - ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) - site_hydr%supsub_flag(:) = 999 - do j=1,site_hydr%nlevsoi_hyd - !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter - ! introduced for the van Genuchten, but does not exist for Campbell SWC. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! watres_local = bc_in(s)%watres_sisl(j) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & + ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) + site_hydr%supsub_flag(:) = 999 + do j=1,site_hydr%nlevsoi_hyd + !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter + ! introduced for the van Genuchten, but does not exist for Campbell SWC. + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! watres_local = bc_in(s)%watres_sisl(j) + case (campbell) + call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & (-1._r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & bc_in(s)%bsw_sisl(j), & tmp1) - call swcCampbell_th_from_satfrac(tmp1, & + call swcCampbell_th_from_satfrac(tmp1, & bc_in(s)%watsat_sisl(j), & watres_local) - case default - end select - do k=1,nshell - if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & + case default + end select + do k=1,nshell + if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & (bc_in(s)%watsat_sisl(j)-small_theta_num)) then site_hydr%supsub_flag(j) = k site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & + else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & (watres_local+small_theta_num)) then site_hydr%supsub_flag(j) = -k site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num - else + else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & - dth_layershell_col(j,k) - end if - enddo - - ! Update the matric potential in the inner-most shell - ! (used for setting tissue potentials of new recruits) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), smp) - site_hydr%psisoi_liq_innershell(j) = smp - - - if(site_hydr%nlevsoi_hyd == 1) then - - bc_out(s)%qflx_soil2root_sisl(1:bc_in(s)%nlevsoil-1) = 0._r8 - - bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell_1D(:)) * & - site_hydr%l_aroot_1D/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & - site_hydr%recruit_w_uptake(site_hydr%nlevsoi_hyd) - - ! Save the amount of liquid soil water known to the model after root uptake - site_hydr%h2osoi_liq_prev(site_hydr%nlevsoi_hyd) = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - & - dtime*bc_out(s)%qflx_soil2root_sisl(bc_in(s)%nlevsoil) - - else - !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) - bc_out(s)%qflx_soil2root_sisl(j) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:)) * & - site_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & - site_hydr%recruit_w_uptake(j) - - ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) - - ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j) - - end if + dth_layershell_col(j,k) + end if + enddo + + ! Update the matric potential in the inner-most shell + ! (used for setting tissue potentials of new recruits) + call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & + bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(j), smp) + site_hydr%psisoi_liq_innershell(j) = smp + + !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) + bc_out(s)%qflx_soil2root_sisl(j) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:)) * & + site_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & + site_hydr%recruit_w_uptake(j) + + ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & + ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + + ! Save the amount of liquid soil water known to the model after root uptake + ! This calculation also assumes that 1mm of water is 1kg + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j) + + enddo !site_hydr%nlevsoi_hyd + + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks - enddo !site_hydr%nlevsoi_hyd - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks - totalrootuptake = 0.0_r8 - totalqtop_dt = 0.0_r8 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ccohort=>cpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - !totalrootuptake = totalrootuptake + ccohort_hydr%rootuptake* ccohort%n/AREA - totalqtop_dt= totalqtop_dt+ ccohort_hydr%qtop_dt* ccohort%n/AREA - ccohort => ccohort%shorter - enddo !cohort - cpatch => cpatch%younger - enddo !patch !remove the recruitment water uptake as it has been added to prev_h2oveg - totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & - site_hydr%recruit_w_uptake(:))*dtime - - total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - totalqtop_dt) - - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e - - bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & - site_hydr%h2oveg_growturn_err - & - site_hydr%h2oveg_pheno_err-& - site_hydr%h2oveg_hydro_err + totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & + site_hydr%recruit_w_uptake(:))*dtime + + total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) + + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e + + bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & + site_hydr%h2oveg_growturn_err - & + site_hydr%h2oveg_pheno_err-& + site_hydr%h2oveg_hydro_err + enddo !site @@ -2840,8 +2590,8 @@ subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) ccohort_hydr => ccohort%co_hydr csite_hydr => csite%si_hydr delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o*delta_n/AREA csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w @@ -2894,7 +2644,7 @@ subroutine RecruitWaterStorage(nsites,sites,bc_out) if(ccohort_hydr%is_newly_recruited) then csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o*currentCohort%n end if @@ -3286,8 +3036,8 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - root_water = (sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' @@ -3507,7 +3257,7 @@ subroutine flc_gs_from_psi(cc_p, lwp ) cCohort => cc_p FT = cCohort%pft - ccohort%co_hydr%btran(:) = & + ccohort%co_hydr%btran = & (1._r8 + (lwp/EDPftvarcon_inst%hydr_p50_gs(ft))**EDPftvarcon_inst%hydr_avuln_gs(ft))**(-1._r8) end subroutine flc_gs_from_psi @@ -5135,4 +4885,45 @@ function xylemtaper(p, dz) result(chi_tapnotap) end function xylemtaper + +!! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + +! This code may be re-introduced at a later date (rgk 08-2019) + +! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP +! first update the leaf water potential memory +!! do t=2, numLWPmem +!!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) +!!end do +!!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) +!!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + +!!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 +!!do k=1,n_hypool_ag +!!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) +!!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling +!! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & +!! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do k=1,n_hypool_troot +!!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) +!!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling +!! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & +!! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do j=1,site_hydr%nlevsoi_hyd +!!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) +!!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling +!! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & +!! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) +!!end if +!!end do +!!end subroutine UpdateLWPMemFLCMin + + end module FatesPlantHydraulicsMod diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 41ed6811d3..95be96375c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -402,17 +402,8 @@ module FatesHistoryInterfaceMod integer :: ih_errh2o_scpf integer :: ih_tran_scpf integer :: ih_rootuptake_scpf + integer :: ih_rootuptake_sl integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension - integer :: ih_rootuptake01_scpf - integer :: ih_rootuptake02_scpf - integer :: ih_rootuptake03_scpf - integer :: ih_rootuptake04_scpf - integer :: ih_rootuptake05_scpf - integer :: ih_rootuptake06_scpf - integer :: ih_rootuptake07_scpf - integer :: ih_rootuptake08_scpf - integer :: ih_rootuptake09_scpf - integer :: ih_rootuptake10_scpf integer :: ih_sapflow_scpf integer :: ih_iterh1_scpf integer :: ih_iterh2_scpf @@ -2964,32 +2955,13 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? - logical :: layer1_present - logical :: layer2_present - logical :: layer3_present - logical :: layer4_present - logical :: layer5_present - logical :: layer6_present - logical :: layer7_present - logical :: layer8_present - logical :: layer9_present - logical :: layer10_present if(hlm_use_planthydro.eq.ifalse) return associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & - hio_rootuptake01_scpf => this%hvars(ih_rootuptake01_scpf)%r82d, & - hio_rootuptake02_scpf => this%hvars(ih_rootuptake02_scpf)%r82d, & - hio_rootuptake03_scpf => this%hvars(ih_rootuptake03_scpf)%r82d, & - hio_rootuptake04_scpf => this%hvars(ih_rootuptake04_scpf)%r82d, & - hio_rootuptake05_scpf => this%hvars(ih_rootuptake05_scpf)%r82d, & - hio_rootuptake06_scpf => this%hvars(ih_rootuptake06_scpf)%r82d, & - hio_rootuptake07_scpf => this%hvars(ih_rootuptake07_scpf)%r82d, & - hio_rootuptake08_scpf => this%hvars(ih_rootuptake08_scpf)%r82d, & - hio_rootuptake09_scpf => this%hvars(ih_rootuptake09_scpf)%r82d, & - hio_rootuptake10_scpf => this%hvars(ih_rootuptake10_scpf)%r82d, & + hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & @@ -3028,68 +3000,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ! on hio_nplant_si_scpf - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=1 ) then - layer1_present = .true. - else - layer1_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=2 ) then - layer2_present = .true. - else - layer2_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=3 ) then - layer3_present = .true. - else - layer3_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=4 ) then - layer4_present = .true. - else - layer4_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=5 ) then - layer5_present = .true. - else - layer5_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=6 ) then - layer6_present = .true. - else - layer6_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=7 ) then - layer7_present = .true. - else - layer7_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=8 ) then - layer8_present = .true. - else - layer8_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=9 ) then - layer9_present = .true. - else - layer9_present = .false. - end if - ! Determine which hydraulic soil layers are present - if( sites(s)%si_hydr%nlevsoi_hyd >=10 ) then - layer10_present = .true. - else - layer10_present = .false. - end if - - cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ccohort => cpatch%shortest @@ -3143,52 +3053,12 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) (ccohort_hydr%qtop_dt + ccohort_hydr%dqtopdth_dthdt) * number_fraction_rate ! [kg/indiv/s] hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake * number_fraction_rate ! [kg/indiv/s] + sum(ccohort_hydr%rootuptake) * number_fraction_rate ! [kg/indiv/s] - - ! Not sure how to simplify this - ! All of these if's inside a cohort loop is not good.... - - if (layer1_present)then - hio_rootuptake01_scpf(io_si,iscpf) = hio_rootuptake01_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake01 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer2_present) then - hio_rootuptake02_scpf(io_si,iscpf) = hio_rootuptake02_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake02 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer3_present) then - hio_rootuptake03_scpf(io_si,iscpf) = hio_rootuptake03_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake03 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer4_present) then - hio_rootuptake04_scpf(io_si,iscpf) = hio_rootuptake04_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake04 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer5_present) then - hio_rootuptake05_scpf(io_si,iscpf) = hio_rootuptake05_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake05 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer6_present) then - hio_rootuptake06_scpf(io_si,iscpf) = hio_rootuptake06_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake06 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer7_present) then - hio_rootuptake07_scpf(io_si,iscpf) = hio_rootuptake07_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake07 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer8_present) then - hio_rootuptake08_scpf(io_si,iscpf) = hio_rootuptake08_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake08 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer9_present) then - hio_rootuptake09_scpf(io_si,iscpf) = hio_rootuptake09_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake09 * number_fraction_rate ! [kg/indiv/s] - end if - if (layer10_present) then - hio_rootuptake10_scpf(io_si,iscpf) = hio_rootuptake10_scpf(io_si,iscpf) + & - ccohort_hydr%rootuptake10 * number_fraction_rate ! [kg/indiv/s] - end if + do j=1,sites(s)%si_hydr%nlevsoi_hyd + hio_rootuptake_sl(io_si,j) = hio_rootuptake_sl(io_si,j) + & + ccohort_hydr%rootuptake(j) * number_fraction_rate ! [kg/indiv/s] + end do hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] @@ -3203,7 +3073,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%th_aroot(1) * number_fraction ! [m3 m-3] hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & - ccohort_hydr%th_troot(1) * number_fraction ! [m3 m-3] + ccohort_hydr%th_troot * number_fraction ! [m3 m-3] hio_sth_scpf(io_si,iscpf) = hio_sth_scpf(io_si,iscpf) + & ccohort_hydr%th_ag(2) * number_fraction ! [m3 m-3] @@ -3215,7 +3085,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%psi_aroot(1) * number_fraction ! [MPa] hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_troot(1) * number_fraction ! [MPa] + ccohort_hydr%psi_troot * number_fraction ! [MPa] hio_swp_scpf(io_si,iscpf) = hio_swp_scpf(io_si,iscpf) + & ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] @@ -3223,11 +3093,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_lwp_scpf(io_si,iscpf) = hio_lwp_scpf(io_si,iscpf) + & ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] - hio_aflc_scpf(io_si,iscpf) = hio_aflc_scpf(io_si,iscpf) + & + hio_aflc_scpf(io_si,iscpf) = hio_aflc_scpf(io_si,iscpf) + & ccohort_hydr%flc_aroot(1) * number_fraction hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_troot(1) * number_fraction + ccohort_hydr%flc_troot * number_fraction hio_sflc_scpf(io_si,iscpf) = hio_sflc_scpf(io_si,iscpf) + & ccohort_hydr%flc_ag(2) * number_fraction @@ -3236,7 +3106,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%flc_ag(1) * number_fraction hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & - ccohort_hydr%btran(1) * number_fraction ! [-] + ccohort_hydr%btran * number_fraction ! [-] endif @@ -4811,56 +4681,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) - call this%set_history_var(vname='FATES_ROOTUPTAKE01_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 1', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake01_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE02_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 2', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake02_scpf ) + call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg/indiv/s', & + long='mean individual root uptake rate per layer', use_default='inactive', & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) - call this%set_history_var(vname='FATES_ROOTUPTAKE03_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 3', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake03_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE04_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 4', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake04_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE05_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 5', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake05_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE06_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 6', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake06_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE07_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 7', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake07_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE08_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 8', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake08_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE09_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 9', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake09_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE10_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate, layer 10', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) - call this%set_history_var(vname='FATES_H2OSOI_COL_SHSL', units='m3/m3', & long='volumetric soil moisture by layer and shell', use_default='inactive', & avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 97c80d5eaf..86518b70f2 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -85,9 +85,9 @@ module FatesHydraulicsMemMod ! may or may not cross that with a simple or ! non-simple layering - real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m3) + real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m3) over the + ! entire site (ha), absolute quantity real(r8),allocatable :: v_shell_init(:,:) ! Previous volume of rhizosphere compartment (m3) - real(r8),allocatable :: v_shell_1D(:) ! Volume of rhizosphere compartment (m3) real(r8),allocatable :: r_node_shell(:,:) ! Nodal radius of rhizosphere compartment (m) real(r8),allocatable :: r_node_shell_init(:,:) ! Previous Nodal radius of rhizosphere compartment (m) real(r8),allocatable :: l_aroot_layer(:) ! Total length (across cohorts) of absorbing @@ -97,27 +97,13 @@ module FatesHydraulicsMemMod real(r8),allocatable :: kmax_upper_shell(:,:) ! Maximum soil hydraulic conductance node k ! to upper (closer to atmosphere) rhiz ! shell boundaries (kg s-1 MPa-1) - real(r8),allocatable :: kmax_bound_shell(:,:) ! Maximum soil hydraulic conductance at upper - ! (closer to atmosphere) rhiz shell - ! boundaries (kg s-1 MPa-1) real(r8),allocatable :: kmax_lower_shell(:,:) ! Maximum soil hydraulic conductance node k ! to lower (further from atmosphere) ! rhiz shell boundaries (kg s-1 MPa-1) real(r8),allocatable :: r_out_shell(:,:) ! Outer radius of rhizosphere compartment (m) - real(r8),allocatable :: r_out_shell_1D(:) ! Outer radius of rhizosphere compartment (m) (USED?) - real(r8),allocatable :: r_node_shell_1D(:) ! Nodal radius of rhizosphere compartment (m) - real(r8),allocatable :: rs1(:) ! Mean fine root radius (m) (currently a constant) - real(r8),allocatable :: kmax_upper_shell_1D(:) ! Maximum soil hydraulic conductance node - ! k to upper (closer to atmosphere) rhiz - ! shell boundaries (kg s-1 MPa-1) - real(r8),allocatable :: kmax_bound_shell_1D(:) ! Maximum soil hydraulic conductance at upper - ! (closer to atmosphere) rhiz shell - ! boundaries (kg s-1 MPa-1) - real(r8),allocatable :: kmax_lower_shell_1D(:) ! Maximum soil hydraulic conductance node - ! k to lower (further from atmosphere) rhiz - ! shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: rs1(:) ! Mean fine root radius (m) (currently a constant) integer,allocatable :: supsub_flag(:) ! index of the outermost rhizosphere shell ! encountering super- or sub-saturation @@ -134,9 +120,6 @@ module FatesHydraulicsMemMod real(r8),allocatable :: recruit_w_uptake(:) ! recruitment water uptake (kg H2o/m2/s) - real(r8) :: l_aroot_1D ! Total (across cohorts) absorbing root - ! length across all layers - real(r8) :: errh2o_hyd ! plant hydraulics error summed across ! cohorts to column level (mm) real(r8) :: dwat_veg ! change in stored water in vegetation @@ -222,35 +205,32 @@ module FatesHydraulicsMemMod real(r8) :: v_ag_init(n_hypool_ag) ! previous day's volume of aboveground water storage compartments [m3] real(r8) :: v_ag(n_hypool_ag) ! volume of aboveground water storage compartments [m3] - real(r8) :: v_troot_init(n_hypool_troot) ! previous day's volume of belowground water storage compartments [m3] - real(r8) :: v_troot(n_hypool_troot) ! volume of belowground water storage compartments [m3] - real(r8) :: v_aroot_tot ! total volume of absorbing roots [m3] - real(r8) :: l_aroot_tot ! total length of absorbing roots [m] + real(r8) :: v_troot_init ! previous day's volume of belowground water storage compartments [m3] + real(r8) :: v_troot ! volume of belowground water storage compartments [m3] real(r8),allocatable :: v_aroot_layer_init(:) ! previous day's volume of absorbing roots by soil layer [m3] real(r8),allocatable :: v_aroot_layer(:) ! volume of absorbing roots by soil layer [m3] real(r8),allocatable :: l_aroot_layer(:) ! length of absorbing roots by soil layer [m] - - ! BC PLANT HYDRAULICS - state variables + + ! State variable, relative water content by volume (i.e. "theta") real(r8) :: th_ag(n_hypool_ag) ! water in aboveground compartments [kgh2o/indiv] - real(r8) :: th_troot(n_hypool_troot) ! water in belowground compartments [kgh2o/indiv] + real(r8) :: th_troot ! water in belowground compartments [kgh2o/indiv] + real(r8),allocatable :: th_aroot(:) ! water in absorbing roots [kgh2o/indiv] + + + ! State diagnostic, water potential real(r8) :: psi_ag(n_hypool_ag) ! water potential in aboveground compartments [MPa] - real(r8) :: psi_troot(n_hypool_troot) ! water potential in belowground compartments [MPa] - real(r8) :: flc_ag(n_hypool_ag) ! fractional loss of conductivity in aboveground compartments [-] - real(r8) :: flc_troot(n_hypool_troot) ! fractional loss of conductivity in belowground compartments [-] - real(r8) :: flc_min_ag(n_hypool_ag) ! min attained fractional loss of conductivity in - ! aboveground compartments (for tracking xylem refilling dynamics) [-] - real(r8) :: flc_min_troot(n_hypool_troot) ! min attained fractional loss of conductivity in - ! belowground compartments (for tracking xylem refilling dynamics) [-] - !refilling status--these are constants are should be moved the fates parameter file(Chonggang XU) - real(r8) :: refill_thresh ! water potential threshold for xylem refilling to occur [MPa] - real(r8) :: refill_days ! number of days required for 50% of xylem refilling to occur [days] - real(r8) :: btran(nlevcan_hyd) ! leaf water potential limitation on gs [0-1] - - real(r8) :: lwp_mem(numLWPmem) ! leaf water potential over the previous numLWPmem timesteps [MPa] - real(r8) :: lwp_stable ! leaf water potential just before it became unstable [MPa] - logical :: lwp_is_unstable ! flag for instability of leaf water potential over previous timesteps + real(r8) :: psi_troot ! water potential in belowground compartments [MPa] + real(r8),allocatable :: psi_aroot(:) ! water potential in absorbing roots [MPa] + + + real(r8) :: btran ! leaf water potential limitation on gs [0-1] + + + ! Variables used for error tracking and flagging + ! ---------------------------------------------------------------------------------- + real(r8) :: supsub_flag ! k index of last node to encounter supersaturation or ! sub-residual water content (+ supersaturation; - subsaturation) real(r8) :: iterh1 ! number of iterations required to achieve tolerable water balance error @@ -267,35 +247,42 @@ module FatesHydraulicsMemMod ! Draw from or add to this pool when ! insufficient plant water available to ! support production of new leaves. - real(r8) :: errh2o_growturn_troot(n_hypool_troot) ! same as errh2o_growturn_ag but for troot pool - real(r8) :: errh2o_pheno_troot(n_hypool_troot) ! same as errh2o_pheno_ag but for troot pool - - ! quantities indexed by soil layer - real(r8),allocatable :: th_aroot(:) ! water in absorbing roots [kgh2o/indiv] - real(r8),allocatable :: psi_aroot(:) ! water potential in absorbing roots [MPa] - real(r8),allocatable :: flc_aroot(:) ! fractional loss of conductivity in absorbing roots [-] - real(r8),allocatable :: flc_min_aroot(:) ! min attained fractional loss of conductivity in absorbing roots - ! (for tracking xylem refilling dynamics) [-] - real(r8),allocatable :: errh2o_growturn_aroot(:) ! same as errh2o_growturn_ag but for aroot pools - real(r8),allocatable :: errh2o_pheno_aroot(:) ! same as errh2o_pheno_ag but for aroot pools - - ! BC PLANT HYDRAULICS - fluxes - ! NOTE: total transpiration is given by qtop_dt + dqtopdth_dthdt + real(r8) :: errh2o_growturn_troot ! same as errh2o_growturn_ag but for troot pool + real(r8) :: errh2o_pheno_troot ! same as errh2o_pheno_ag but for troot pool + real(r8) :: errh2o_growturn_aroot ! same as errh2o_growturn_ag but for aroot pools + real(r8) :: errh2o_pheno_aroot ! same as errh2o_pheno_ag but for aroot pools + + + + ! Useful diagnostics + ! ---------------------------------------------------------------------------------- + real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] - real(r8) :: rootuptake ! net flow into roots (+ into roots) [kg/indiv/timestep] - real(r8) :: rootuptake01 ! net flow into roots (+ into roots), soil layer 1 [kg/indiv/timestep] - real(r8) :: rootuptake02 ! net flow into roots (+ into roots), soil layer 2 [kg/indiv/timestep] - real(r8) :: rootuptake03 ! net flow into roots (+ into roots), soil layer 3 [kg/indiv/timestep] - real(r8) :: rootuptake04 ! net flow into roots (+ into roots), soil layer 4 [kg/indiv/timestep] - real(r8) :: rootuptake05 ! net flow into roots (+ into roots), soil layer 5 [kg/indiv/timestep] - real(r8) :: rootuptake06 ! net flow into roots (+ into roots), soil layer 6 [kg/indiv/timestep] - real(r8) :: rootuptake07 ! net flow into roots (+ into roots), soil layer 7 [kg/indiv/timestep] - real(r8) :: rootuptake08 ! net flow into roots (+ into roots), soil layer 8 [kg/indiv/timestep] - real(r8) :: rootuptake09 ! net flow into roots (+ into roots), soil layer 9 [kg/indiv/timestep] - real(r8) :: rootuptake10 ! net flow into roots (+ into roots), soil layer 10 [kg/indiv/timestep] + real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/indiv/timestep] ! BC PLANT HYDRAULICS - flags - logical :: is_newly_recruited !whether the new cohort is newly recruited + + + ! Other + ! ---------------------------------------------------------------------------------- + logical :: is_newly_recruited ! whether the new cohort is newly recruited + + + + ! ---------------------------------------------------------------------------------- + ! NOT USED, BUT HOLDING FOR FUTURE RE-IMPLEMENTATION + !real(r8) :: flc_min_ag(n_hypool_ag) ! min attained fractional loss of conductivity in + ! ! aboveground compartments (for tracking xylem refilling dynamics) [-] + !real(r8) :: flc_min_troot(n_hypool_troot) ! min attained fractional loss of conductivity in + ! ! belowground compartments (for tracking xylem refilling dynamics) [-] + !real(r8),allocatable :: flc_min_aroot(:) ! min attained fractional loss of conductivity in absorbing roots + ! ! (for tracking xylem refilling dynamics) [-] + !real(r8) :: lwp_mem(numLWPmem) ! leaf water potential over the previous numLWPmem timesteps [MPa] + !real(r8) :: lwp_stable ! leaf water potential just before it became unstable [MPa] + !logical :: lwp_is_unstable ! flag for instability of leaf water potential over previous timesteps + !real(r8) :: refill_thresh ! water potential threshold for xylem refilling to occur [MPa] + !real(r8) :: refill_days ! number of days required for 50% of xylem refilling to occur [days] + ! ----------------------------------------------------------------------------------- contains procedure :: AllocateHydrCohortArrays @@ -314,21 +301,17 @@ subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) class(ed_cohort_hydr_type),intent(inout) :: this integer, intent(in) :: nlevsoil_hydr - allocate(this%z_node_aroot(1:nlevsoil_hydr)) - allocate(this%kmax_treebg_layer(1:nlevsoil_hydr)) + allocate(this%kmax_troot_lower(1:nlevsoil_hydr)) + allocate(this%kmax_aroot_upper(1:nlevsoil_hydr)) + allocate(this%kmax_aroot_radial_in(1:nlevsoil_hydr)) + allocate(this%kmax_aroot_radial_out(1:nlevsoil_hydr)) allocate(this%v_aroot_layer_init(1:nlevsoil_hydr)) allocate(this%v_aroot_layer(1:nlevsoil_hydr)) allocate(this%l_aroot_layer(1:nlevsoil_hydr)) allocate(this%th_aroot(1:nlevsoil_hydr)) - !allocate(this%th_aroot_prev(1:nlevsoil_hydr)) - !allocate(this%th_aroot_prev_uncorr(1:nlevsoil_hydr)) allocate(this%psi_aroot(1:nlevsoil_hydr)) - allocate(this%flc_aroot(1:nlevsoil_hydr)) - allocate(this%flc_min_aroot(1:nlevsoil_hydr)) - allocate(this%errh2o_growturn_aroot(1:nlevsoil_hydr)) - allocate(this%errh2o_pheno_aroot(1:nlevsoil_hydr)) - allocate(this%kmax_innershell(1:nlevsoil_hydr)) - + allocate(this%rootuptake(1:nlevsoil_hydr)) + return end subroutine AllocateHydrCohortArrays @@ -337,20 +320,17 @@ end subroutine AllocateHydrCohortArrays subroutine DeallocateHydrCohortArrays(this) class(ed_cohort_hydr_type),intent(inout) :: this - deallocate(this%z_node_aroot) - deallocate(this%kmax_treebg_layer) + + deallocate(this%kmax_troot_lower) + deallocate(this%kmax_aroot_upper) + deallocate(this%kmax_aroot_radial_in) + deallocate(this%kmax_aroot_radial_out) deallocate(this%v_aroot_layer_init) deallocate(this%v_aroot_layer) deallocate(this%l_aroot_layer) deallocate(this%th_aroot) - !deallocate(this%th_aroot_prev) - !deallocate(this%th_aroot_prev_uncorr) deallocate(this%psi_aroot) - deallocate(this%flc_aroot) - deallocate(this%flc_min_aroot) - deallocate(this%errh2o_growturn_aroot) - deallocate(this%errh2o_pheno_aroot) - deallocate(this%kmax_innershell) + deallocate(this%rootuptake) return end subroutine DeallocateHydrCohortArrays @@ -366,20 +346,13 @@ subroutine InitHydrSite(this) allocate(this%v_shell(1:nlevsoil_hyd,1:nshell)) ; this%v_shell = nan allocate(this%v_shell_init(1:nlevsoil_hyd,1:nshell)) ; this%v_shell_init = nan - allocate(this%v_shell_1D(1:nshell)) ; this%v_shell_1D = nan allocate(this%r_node_shell(1:nlevsoil_hyd,1:nshell)) ; this%r_node_shell = nan allocate(this%r_node_shell_init(1:nlevsoil_hyd,1:nshell)); this%r_node_shell_init = nan allocate(this%r_out_shell(1:nlevsoil_hyd,1:nshell)) ; this%r_out_shell = nan allocate(this%l_aroot_layer(1:nlevsoil_hyd)) ; this%l_aroot_layer = nan allocate(this%l_aroot_layer_init(1:nlevsoil_hyd)) ; this%l_aroot_layer_init = nan allocate(this%kmax_upper_shell(1:nlevsoil_hyd,1:nshell)); this%kmax_upper_shell = nan - allocate(this%kmax_bound_shell(1:nlevsoil_hyd,1:nshell)); this%kmax_bound_shell = nan allocate(this%kmax_lower_shell(1:nlevsoil_hyd,1:nshell)); this%kmax_lower_shell = nan - allocate(this%r_out_shell_1D(1:nshell)) ; this%r_out_shell_1D = nan - allocate(this%r_node_shell_1D(1:nshell)) ; this%r_node_shell_1D = nan - allocate(this%kmax_upper_shell_1D(1:nshell)) ; this%kmax_upper_shell_1D = nan - allocate(this%kmax_bound_shell_1D(1:nshell)) ; this%kmax_bound_shell_1D = nan - allocate(this%kmax_lower_shell_1D(1:nshell)) ; this%kmax_lower_shell_1D = nan allocate(this%supsub_flag(1:nlevsoil_hyd)) ; this%supsub_flag = -999 allocate(this%h2osoi_liqvol_shell(1:nlevsoil_hyd,1:nshell)) ; this%h2osoi_liqvol_shell = nan allocate(this%h2osoi_liq_prev(1:nlevsoil_hyd)) ; this%h2osoi_liq_prev = nan @@ -387,15 +360,14 @@ subroutine InitHydrSite(this) allocate(this%rs1(1:nlevsoil_hyd)); this%rs1(:) = fine_root_radius_const allocate(this%recruit_w_uptake(1:nlevsoil_hyd)); this%recruit_w_uptake = nan - this%l_aroot_1D = nan this%errh2o_hyd = nan this%dwat_veg = nan this%h2oveg = 0.0_r8 this%h2oveg_recruit = 0.0_r8 this%h2oveg_dead = 0.0_r8 - this%h2oveg_growturn_err = 0.0_r8 + this%h2oveg_growturn_err = 0.0_r8 this%h2oveg_pheno_err = 0.0_r8 - this%h2oveg_hydro_err = 0.0_r8 + this%h2oveg_hydro_err = 0.0_r8 end associate From 6aafb40c97254175871708a56bebaf1dc56ea2f1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 31 Aug 2019 14:38:45 -0700 Subject: [PATCH 010/114] Moved hydro solver code back to FatesPlantHydraulicsMod. --- biogeophys/FatesHydroSolversMod.F90 | 742 ------------- biogeophys/FatesPlantHydraulicsMod.F90 | 1362 +++++++++++++++++------- 2 files changed, 994 insertions(+), 1110 deletions(-) diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 index e9e92a0e18..1219dd9aa7 100644 --- a/biogeophys/FatesHydroSolversMod.F90 +++ b/biogeophys/FatesHydroSolversMod.F90 @@ -5,749 +5,7 @@ module FatesHydroSolversMod contains - subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) - ! --------------------------------------------------------------------------------- - ! - ! This routine sets the maximum conductance of all compartments in the plant, from - ! leaves, to stem, to transporting root, to the absorbing roots. - ! These properties are dependent only on the materials (conductivity) and the - ! geometry of the compartments. - ! The units of all K_max values are [kg H2O s-1 MPa-1] - ! - ! There are some different ways to represent overall conductance from node-to-node - ! throughout the hydraulic system. Universally, all can make use of a system - ! where we separate the hydraulic compartments of the nodes into the upper (closer - ! to the sky) and lower (away from the sky) portions of the compartment. It is - ! possible that due to things like xylem taper, the two portions may have different - ! conductivity, and therefore differnet conductances. - ! - ! Assumption 0. This routine calculates maximum conductivity for 1 plant. - ! Assumption 1. The compartment volumes, heights and lengths have all been - ! determined, probably called just before this routine. - ! - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! --------------------------------------------------------------------------------- - - ! Arguments - - type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr - type(ed_cohort_type),intent(in),target :: ccohort - type(ed_site_hydr_type),intent(in),target :: csite_hydr - type(bc_in_type),intent(in) :: bc_in - - - - ! Locals - integer :: k ! Compartment (node) index - integer :: k_ag ! Compartment index for above-ground indexed array - integer :: pft ! Plant Functional Type index - real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] - real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] - real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] - real(r8) :: z_node ! distance between compartment center and mph [m] - real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] - real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways - ! [kg-1 s MPa] - real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways - ! from the absorbing roots center nodes to the - ! transporting root center node - real(r8) :: rootfr ! fraction of absorbing root in each soil layer - ! assumes propotion of absorbing root is equal - ! to proportion of total root - real(r8) :: kmax_layer ! max conductance between transporting root node - ! and absorbing root node in each layer [kg s-1 MPa-1] - real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each - ! soil layer [m2] - - real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] - - - pft = ccohort%pft - - ! Get the cross-section of the plant's sapwood area [m2] - call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) - - - ! Leaf Maximum Hydraulic Conductance - ! The starting hypothesis is that there is no resistance inside the - ! leaf, between the petiole and the center of storage. To override - ! this, make provisions by changing the kmax to a not-absurdly high - ! value. It is assumed that the conductance in this default case, - ! is regulated completely by the stem conductance from the stem's - ! center of storage, to the petiole. - - ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 - - - ! Stem Maximum Hydraulic Conductance - - do k=1, n_hypool_stem - - ! index for "above-ground" arrays, that contain stem and leaf - ! in one vector - k_ag = k+n_hypool_leaf - - ! Depth from the petiole to the lower, node and upper compartment edges - - z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) - z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) - z_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_upper_ag(k_ag) - - - ! Then we calculate the maximum conductance from each the lower, node and upper - ! edges of the compartment to the petiole. The xylem taper factor requires - ! that the kmax it is scaling is from the point of interest to the mean height - ! of the petioles. Then we can back out the conductance over just the path - ! of the upper and lower compartments, but subtracting them as resistors in - ! series. - - ! max conductance from upper edge to mean petiole height - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, z_upper) * & - a_sapwood / z_upper - - ! max conductance from node to mean petiole height - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, z_node) * & - a_sapwood / z_node - - ! max conductance from lower edge to mean petiole height - kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, z_lower) * & - a_sapwood / z_lower - - ! Max conductance over the path of the upper side of the compartment - ccohort_hydr%kmax_stem_upper(k_ag) = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 - - ! Max conductance over the path on the loewr side of the compartment - ccohort_hydr%kmax_stem_lower(k_ag) = (1._r8/kmax_lower - 1._r8/kmax_node)**-1._r8 - - - enddo - - ! Maximum conductance of the upper compartment in the transporting root - ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - - z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) - z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot - - - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, z_node) * & - a_sapwood / z_node - - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(taper_exponent, z_upper) * & - a_sapwood / z_upper - - ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 - - - ! The maximum conductance between the center node of the transporting root - ! compartment, and the center node of the absorbing root compartment, is calculated - ! as a residual. Specifically, we look at the total resistance the plant has in - ! the stem so far, by adding those resistances in series. - ! Then we use a parameter to specify what fraction of the resistance - ! should be below-ground between the transporting root node and the absorbing roots. - ! After that total is calculated, we then convert to a conductance, and split the - ! conductance in parallel between root layers, based on the root fraction. - ! Note* The inverse of max conductance (KMax) is minimum resistance: - - - rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & - sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & - sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & - 1._r8/kmax_troot_upper - - ! Calculate the residual resistance below ground, as a resistor - ! in series with the existing above ground - ! Invert to find below-ground kmax - kmax_bg = 1._r8/(rmin_ag * (1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - - ! The max conductance of each layer is in parallel, therefore - ! the kmax terms of each layer, should sum to kmax_bg - do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - - kmax_layer = rootfr*kmax_bg - - ! Two transport pathways, in two compartments exist in each layer. - ! These pathways are connected in serial. - ! For simplicity, we simply split the resistance between the two. - ! Mathematically, this results in simply doubling the conductance - ! and applying to both paths. Here are the two paths: - ! 1) is the path between the transporting root's center node, to - ! the boundary of the transporting root with the boundary of - ! the absorbing root (kmax_troot_lower) - ! 2) is the path between the boundary of the absorbing root and - ! transporting root, with the absorbing root's center node - ! (kmax_aroot_upper) - - ccohort_hydr%kmax_troot_lower(j) = 2.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_upper(j) = 2.0_r8 * kmax_layer - - end do - - ! Finally, we calculate maximum radial conductance from the root - ! surface to its center node. This transport is not a xylem transport - ! like the calculations prior to this. This transport is through the - ! exodermis, cortex, casparian strip and endodermis. The actual conductance - ! will possibly depend on the potential gradient (whether out-of the root, - ! or in-to the root). So we calculate the kmax's for both cases, - ! and save them for the final conductance calculation. - - do j=1,nlevsoi_hyd - - ! Surface area of the absorbing roots for this cohort in this layer [m2] - surfarea_aroot_layer = 2._r8 * pi_const *csite_hydr%rs1(j) * ccohort_hydr%l_aroot_layer(j) - - ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] - ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer - - ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer - - end do - - - return - end subroutine UpdatePlantKMax - - ! =================================================================================== - - subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top,d_th_node,sapflow,rootuptake,wb_err) - - ! ------------------------------------------------------------------------------- - ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and - ! the list need not be across the whole path from stomata to the last rhizosphere shell, but - ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. - ! ------------------------------------------------------------------------------- - - ! !ARGUMENTS - type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr - type(ed_site_hydr_type), intent(in),target :: site_hydr - integer , intent(in) :: ilayer ! soil layer index of interest - real(r8) , intent(in) :: psi_node(:) ! matric potential of nodes [Mpa] - real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] - real(r8) , intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8) , intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] - real(r8),intent(out) :: d_th_node(n_hypool_tot) ! change in theta over the timestep - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - real(r8),intent(out) :: wb_err ! transpiration should match change in storage [kg] - - ! Locals - - integer :: inode ! node index "i" - integer :: jpath ! path index "j" - integer :: ishell ! rhizosphere shell index of the node - integer :: i_dn ! downstream node of current flow-path - integer :: i_up ! upstream node of current flow-path - integer :: iter ! iteration count for sub-steps - logical :: solution_found ! logical set to true if a solution was found within error tolerance - real(r8) :: kmax_up ! maximum conductance of the upstream half of path [kg s-1 Mpa-1] - real(r8) :: kmax_dn ! maximum conductance of the downstream half of path [kg s-1 MPa-1] - real(r8) :: wb_step_err - real(r8) :: wb_err ! sum of water balance error over substeps - real(r8) :: leaf_water ! kg of water in the leaf - real(r8) :: stem_water ! kg of water in the stem - real(r8) :: root_water ! kg of water in the transp and absorbing roots - real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] - real(r8) :: th_node(n_hypool_tot) - real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] - real(r8) :: v_node(n_hypool_tot) ! volume of the node [m3] - real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] - real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] - real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] - real(r8) :: dftc_dtheta_node(n_hypool_tot) ! deriv FTC w.r.t. theta - real(r8) :: dpsi_dtheta_node(n_hypool_tot) ! deriv psi w.r.t. theta - real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] - real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] - real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] - real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta - real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta - real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta - real(r8) :: tris_r(n_hypool_tot) - - integer, parameter :: max_iter = 5 - real(r8), parameter :: max_wb_step_err = 1.e-6_r8 - real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] - - ! ------------------------------------------------------------------------------- - ! Part 1. Calculate node quantities: - ! matric potential: psi_node - ! fraction of total conductance: ftc_node - ! total potential (matric + elevatio) h_node - ! deriv. ftc wrt theta: dftc_dtheta_node - ! deriv. psi wrt theta: dpsi_dtheta_node - ! ------------------------------------------------------------------------------- - - - - ! For all nodes leaf through rhizosphere - ! Send node heights and compartment volumes to a node-based array - - do inode = 1,n_hypool_tot - - if (inode<=n_hypool_ag) then - z_node(inode) = ccohort_hydr%z_node_ag(inode) - v_node(inode) = ccohort_hydr%v_node_ag(inode) - th_node_init(inode) = ccohort_hydr%th_ag(inode) - elseif (inode==n_hypool_ag+1) then - z_node(inode) = ccohort_hydr%z_node_troot - v_node(inode) = ccohort_hydr%v_troot - th_node_init(inode) = ccohort_hydr%th_troot - elseif (inode==n_hyppol_ag+2) then - z_node(inode) = bc_in(s)%z_sisl(ilayer) - v_node(inode) = ccohort_hydr%v_aroot_layer(:) - th_node_init(inode) = ccohort_hyd%th_aroot(ilayer) - else - ishell = inode-(n_hypool_tot+2) - z_node(inode) = bc_in(s)%z_sisl(ilayer) - v_node(inode) = csite_hydr%v_shell(ilayer,ishell) - th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) - end if - - end do - - - ! Outer iteration loop - ! This cuts timestep in half and resolve the solution with smaller substeps - ! This loop is cleared when the model has found a solution - - solution_found = .false. - iter = 0 - do while( .not.solution_found ) - - ! These are diagnostics that must be calculated. - ! in this routine (uses differentials and actual fluxes) - ! So we need to zero them, as they are incremented - ! over the sub-steps - - sapflow = 0._r8 - rootuptake = 0._r8 - wb_err = 0._r8 - - ! Gracefully quit if too many iterations have been used - if(iter>max_iter)then - write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' - write(fates_log(),*) '' - leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & - ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - root_water = (ccohort_hydr%th_troot*ccohort_hydr%v_troot) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',ccohort%dbh - write(fates_log(),*) 'pft: ',ccohort%pft - write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! For each attempt, we want to reset theta with the initial value - th_node(:) = th_node_init(:) - - - ! Determine how many substeps, and how long they are - - nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. - - dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - - ! Walk through sub-steps - do istep = 1,nsteps - - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node(:)*v_node(:))*denh2o - - ! Calculate on-node quantities: potential, and derivatives - do inode = 1,n_hypool_tot - - ! Get matric potential [Mpa] - call psi_from_th(currentCohort%pft, porous_media(inode), th_node(inode), & - psi_node(inode), site_hydr, bc_in) - - ! Get total potential [Mpa] - h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) - - ! Get Fraction of Total Conductivity [-] - call flc_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & - ftc_node(inode), site_hydr, bc_in) - - ! deriv ftc wrt theta - call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & - dpsi_dtheta_node(inode), site_hydr, bc_in) - - call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & - dftc_dpsi, site_hydr, bc_in) - - dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) - - end do - - - !-------------------------------------------------------------------------------- - ! Part 2. Effective conductances over the path-length and Flux terms - ! over the node-to-node paths - !-------------------------------------------------------------------------------- - - ! Path is between the leaf node and first stem node - ! ------------------------------------------------------------------------------- - - jpath = 1 - i_dn = 1 - i_up = 2 - kmax_dn = cohort_hydr%kmax_petiole_to_leaf - kmax_up = cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- - - do jpath=2,n_hypool_ag-1 - - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) - kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - end do - - - ! Path is between lowest stem and transporting root - - jpath = n_hypool_ag - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) - kmax_lo = cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between the transporting root - ! and the absorbing root for this layer - - jpath = n_hypool_ag+1 - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - jpath = n_hypool_ag+2 - i_dn = jpath - i_up = jpath+1 - - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then - kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) - else - kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) - end if - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - ! Path is between rhizosphere shells - - do jpath = n_hypool_ag+3,n_hpool_tot-1 - - i_dn = jpath - i_up = jpath+1 - ishell_dn = i_dn - (n_hypool_ag+2) - ishell_up = i_up - (n_hypool_ag+2) - kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up) - kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) - - - end do - - ! ------------------------------------------------------------------------------- - ! Part 3. - ! Loop through nodes again, build matrix - ! ------------------------------------------------------------------------------- - - tris_a(1) = 0._r8 - tris_b(1) = A_term(1) - denh20*vol_node(1)/dt_substep - tris_c(1) = B_term(1) - tris_r(1) = q_top - k_eff(1)*(h_node(2)-h_node(1)) - - - do inode = 2,n_hypool_tot-1 - jpath = inode - tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep - tris_c(inode) = B_term(jpath) - tris_r(inode) = -k_eff(jpath)*(h_node(inode+1)-h_node(inode)) + & - k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) - - end do - - inode = n_hypool_tot - jpath = n_hypool_tot - tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = -B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep - tris_c(inode) = 0._r8 - tris_r(inode) = k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) - - - ! Calculate the change in theta - - call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) - - - ! Catch super-saturated and sub-residual water contents - - ! Mass error (flux - change) - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_end = sum((th_node(:)+dth_node(:))*v_node(:))*denh2o - - wb_step_err = (q_top*dt_substep) - (w_tot_beg-w_tot_end) - - if(abs(wb_step_err)>max_wb_step_err)then - solution_found = .false. - exit - else - ! Note: this is somewhat of a default true. And the sub-steps - ! will keep going unless its changed and broken out of - ! the loop. - solution_found = .true. - end if - - ! If we have not broken from the substep loop, - ! that means this sub-step has been acceptable, and we may - ! go ahead and update the water content for the integrator - - th_node(:) = th_node(:) + dth_node(:) - - ! Accumulate the water balance error for diagnostic purposes - wb_err = wb_err + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - inode = n_hypool_ag - sapflow = sapflow + dt_substep * & - (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) - A_term(inode)*dth_node(inode) + & ! dq at node i - B_term(inode)*dth_node(inode+1)) ! dq at node i+1 - - ! Root uptake is the integrated flux between the first rhizosphere - ! shell and the absorbing root - - inode = h_hypool_ag+2 - rootuptake = rootuptake + dt_substep * & - (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) - A_term(inode)*dth_node(inode) + & ! dq at node i - B_term(inode)*dth_node(inode+1)) ! dq at node i+1 - - - end do ! do istep = 1,nsteps (substep loop) - - iterh1=iterh1+1 - - end do - - ! Save the number of times we refined our sub-step counts (iterh1) - ccohort_hydr%iterh1 = real(iterh1) - ! Save the number of sub-steps we ultimately used - ccohort_hydr%iterh2 = real(nsteps) - - ! ----------------------------------------------------------- - ! To a final check on water balance error sumed over sub-steps - ! ------------------------------------------------------------ - if ( abs(wb_err) > max_wb_err ) then - - write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' - - leaf_water = ccohort_hydr%th_ag(1)*ccohort_hydr%v_ag(1)*denh2o - stem_water = sum(ccohort_hydr%th_ag(2:n_hypool_ag) * & - ccohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o - - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',ccohort%dbh - write(fates_log(),*) 'pft: ',ccohort%pft - write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! Adjust final water balance by adding back in the error term - ! ------------------------------------------------------------ - - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then - if(debug) then - write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' - endif - !dump the error water to the bin with largest water storage - max_l = maxloc(th_node(:)*v_node(:),dim=1) - th_node(max_l) = th_node(max_l)- & - we_tot_outer/(v_node(max_l)*denh2o) - th_node(max_l) = min (th_node(max_l),& - ths_node(max_l)-small_theta_num) - th_node(max_l) = max(th_node(max_l),& - thr_node(max_l)+small_theta_num) - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - end if - - - - ! If we have made it to this point, supposedly we have completed the whole time-step - ! for this cohort x layer combination. It is now safe to save the delta theta - ! value and pass it back to the calling routine. The value passed back is the - ! change in theta over all sub-steps. - - dth_node(:) = th_node(:)-th_node_init(:) - - - - return - end subroutine ImTaylorSolverTermsCond1D - - ! ================================================================================= - - subroutine GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_up,ftc_dn, & - h_up,h_dn, & - dftc_dtheta_up, dftc_dtheta_dn, & - dpsi_dtheta_up, dpsi_dtheta_dn, & - k_eff, & - A_term, & - B_term) - - ! ----------------------------------------------------------------------------- - ! This routine will return the effective conductance "K", as well - ! as two terms needed to calculate the implicit solution (using taylor - ! first order expansion). The two terms are generically named A & B. - ! Thus the name "KAB". These quantities are specific not to the nodes - ! themselves, but to the path between the nodes, defined as positive - ! direction from upstream node to downstream node. - ! ----------------------------------------------------------------------------- - - real(r8),intent(in) :: kmax_up, kmax_dn ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: ftc_up, ftc_dn ! frac total conductance [-] - real(r8),intent(in) :: h_up, h_dn ! total potential [Mpa] - real(r8),intent(in) :: dftc_dtheta_up, dftc_dtheta_dn ! Derivative - ! of FTC wrt relative water content - - real(r8),intent(in) :: dpsi_dtheta_up, dpsi_dtheta_dn ! Derivative of matric potential - ! wrt relative water content - - real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - real(r8),intent(in) :: a_term ! "A" term for path (See tech note) - real(r8),intent(in) :: b_term ! "B" term for path (See tech note) - - - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_dn*kmax_dn)+1._r8/(ftc_up*kmax_up)) - - ! Calculate difference in total potential over the path [MPa] - h_diff = h_up - h_dn - - ! "A" term, which operates on the down-stream node - A_term = (k_eff**2.0_r8) * h_diff * (kmax_dn**-1.0_r8) * (ftc_dn**-2.0_r8) & - * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn - - ! "B" term, which operates on the up-stream node - B_term = (k_eff**2.0_r8) * h_diff * (kmax_up**-1.0_r8) * (ftc_up**-2.0_r8) & - * dftc_dtheta_up + k_eff * dpsi_dtheta_up - - - - return - end subroutine GetImTaylorTerms diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 321b3aa788..9469f11380 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -47,6 +47,8 @@ module FatesPlantHydraulicsMod use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : AREA_INV + use EDTypesMod , only : AREA use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type @@ -98,6 +100,10 @@ module FatesPlantHydraulicsMod integer, parameter :: campbell = 2 integer :: iswc = campbell + integer, parameter :: bcvol = 1 + integer, parameter :: rkvol = 2 + integer, parameter :: voltype = rkvol + ! 1=leaf, 2=stem, 3=troot, 4=aroot ! Several of these may be better transferred to the parameter file in due time (RGK) @@ -153,7 +159,6 @@ module FatesPlantHydraulicsMod public :: SavePreviousRhizVolumes public :: UpdateTreeHydrNodes public :: UpdateTreeHydrLenVol - public :: KmaxInnerShell public :: ConstrainRecruitNumber !------------------------------------------------------------------------------ @@ -334,7 +339,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 call th_from_psi(ft, 3, ccohort_hydr%psi_troot, ccohort_hydr%th_troot, csite%si_hydr, bc_in) - + !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below @@ -504,7 +509,7 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) ! volumes, and UpdateTreeHydrNodes is called prior to this. call UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) - + ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(ccohort_hydr,ccohort,currentsite%si_hydr,bc_in) @@ -602,7 +607,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] - + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft @@ -692,148 +697,26 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & - l_aroot_tot + l_aroot_tot ! Partition the total absorbing root lengths and volumes into the active soil layers ! ------------------------------------------------------------------------------ do j=1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) - end if - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot + ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot end do end if !check for bleaf end subroutine UpdateTreeHydrLenVol - - !===================================================================================== - - subroutine KmaxInnerShell(currentSite, ccohort, hksat_soil, kmax_innershell) - - ! ----------------------------------------------------------------------------------- - ! This subroutine calculates update the conductance across the soil to root - ! interface depending on the plant water uptake/loss. - ! we assume that the conductivitity for water uptake is larger than - ! water loss due to composite regulation of resistance the roots - ! hydraulic vs osmostic with and without transpiration. - ! - ! Output: conductance at soil-root inerface (each layer): - ! ccohort_hydr%kmax_innershell(j) [kg s-1 MPa-1 ] - - ! Consider M Williams et al. 1996 - ! Consider Kennedy et al. 2019 - ! https://agupubs.onlinelibrary.wiley.com/doi/full/10.1029/2018MS001500 - ! - ! flux = conductance * area * (delta psi + delta z) - ! - ! - - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! ----------------------------------------------------------------------------------- - - ! Arguments - type(ed_site_type) , intent(in) :: currentSite ! Site target - type(ed_cohort_type),intent(inout) :: ccohort ! cohort target - real(r8),intent(in) :: hksat_soil(:) ! Saturated Hydraulic conductivity - ! of the soil [mm H2O s-1] - real(r8),intent(out) :: kmax_innershell(:) - - type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure - type(ed_site_hydr_type),pointer :: csite_hydr - - integer :: j ! loop index for soil layers - real(r8) :: hksat_s ! hydraulic conductivity at saturation [kg s-1 MPa-1] - - ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] - ! - ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 - ! - ! [mm s-1] * 1e-3 [m mm-1] - ! * 1 [kg m-1 s-2 Pa-1] - ! * 9.8-1 [s2 m-1] - ! * 1e6 [Pa MPa-1] - ! = [kg s-1 m-1 MPa-1] - real(r8) :: kmax_root_surf_total ! maximum conducitivity for total - ! root surface [kg MPa-1 s-1] - real(r8) :: kmax_soil_total ! maximum conducitivity for from root - ! surface to soil shell(kg water/Mpa/s) - ! which is equiv to [kg m-1 s-1 MPa-1] - real(r8) :: kmax_root_surf ! maximum conducitivity for unit root - ! surface (kg water/m2 root area/Mpa/s) - - integer, parameter :: k_inner = 1 ! index for the inner rhizosphere shell (closest to root) - logical, parameter :: use_kmax_rootsurf_smoothing = .false. ! If this is true, use a root surface conductivity - ! that is a linear function of the potential ratio of - ! the absorbing root and the inner shell - - - ccohort_hydr => ccohort%co_hydr - csite_hydr => currentSite%si_hydr - - do j=1, csite_hydr%nlevsoi_hyd - - hksat_s = hksat_soil(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa - - psi_ratio = ccohort_hydr%psi_aroot(j)/csite_hydr%psisoi_liq_innershell(j) - - if(use_kmax_rootsurf_smoothing) then - - psi_ratio = ccohort_hydr%psi_aroot(j)/csite_hydr%psisoi_liq_innershell(j) - - ! if psi_ratio > 1.5, then the root is pretty dry compared to the soil - ! and we use the hydr_kmax_rsurf1. If it below 0.667, then the soil - ! is pretty dry compared to root, and use hydr_kmax_rsurf2 - - slope = (hydr_kmax_rsurf1-hydr_kmax_rsurf2)/(1.5-0.666) - - kmax_root_surf = hydr_kmax_rsurf2 + min(hydr_kmax_rsurf1,max(0._r8,(psi_ratio-0.666)*slope)) - - - else - if(ccohort_hydr%psi_aroot(j) root radius - ! then we add this resistance in series to the other terms - - else - - ! A = L*2*Pi / log(r_shell/r_root) * [kg s-1 m-1 MPa-1] - - kmax_soil_total = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s - - kmax_innershell(j) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**(-1._r8) - end if - end do - - end subroutine KmaxInnerShell - ! ===================================================================================== subroutine updateSizeDepTreeHydStates(currentSite,ccohort) @@ -842,7 +725,6 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! ! !USES: use FatesUtilsMod , only : check_var_real - use EDTypesMod , only : AREA ! !ARGUMENTS: type(ed_site_type) , intent(in) :: currentSite ! Site stuff @@ -880,25 +762,25 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ccohort_hydr%errh2o_growturn_aroot = 0._r8 do j=1,currentSite%si_hydr%nlevsoi_hyd - th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & - ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) - ccohort_hydr%errh2o_growturn_aroot = ccohort_hydr%errh2o_growturn_aroot + & - denh2o*cCohort%n/AREA*(ccohort_hydr%th_aroot(j)-th_aroot_uncorr(j))*ccohort_hydr%v_aroot_layer(j) + th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & + ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) + ccohort_hydr%errh2o_growturn_aroot = ccohort_hydr%errh2o_growturn_aroot + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_aroot_uncorr(j))*ccohort_hydr%v_aroot_layer(j) enddo ! Storing mass balance error ! + means water created; - means water destroyed - ccohort_hydr%errh2o_growturn_ag(:) = denh2o*cCohort%n/AREA*ccohort_hydr%v_ag(:) * & - (ccohort_hydr%th_ag(:)-th_ag_uncorr(:)) - ccohort_hydr%errh2o_growturn_troot = denh2o*cCohort%n/AREA*ccohort_hydr%v_troot * & - (ccohort_hydr%th_troot-th_troot_uncorr) + ccohort_hydr%errh2o_growturn_ag(:) = denh2o*cCohort%n*AREA_INV*ccohort_hydr%v_ag(:) * & + (ccohort_hydr%th_ag(:)-th_ag_uncorr(:)) + ccohort_hydr%errh2o_growturn_troot = denh2o*cCohort%n*AREA_INV*ccohort_hydr%v_troot * & + (ccohort_hydr%th_troot-th_troot_uncorr) csite_hydr =>currentSite%si_hydr csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & - sum(ccohort_hydr%errh2o_growturn_ag(:)) + & - ccohort_hydr%errh2o_growturn_troot + & - ccohort_hydr%errh2o_growturn_aroot + sum(ccohort_hydr%errh2o_growturn_ag(:)) + & + ccohort_hydr%errh2o_growturn_troot + & + ccohort_hydr%errh2o_growturn_aroot ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 @@ -1045,10 +927,10 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & ccohort_hydr%flc_ag(k), site_hydr, bc_in) end do - + call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot, site_hydr, bc_in) - + ccohort_hydr%psi_troot, site_hydr, bc_in) + do j=1,site_hydr%nlevsoi_hyd call psi_from_th(currentCohort%pft, 4, ccohort_hydr%th_aroot(j), & ccohort_hydr%psi_aroot(j), site_hydr, bc_in) @@ -1249,8 +1131,6 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) ! plants. This value is necessary for water balancing in the HLM. ! ---------------------------------------------------------------------------------- - use EDTypesMod, only : AREA - ! Arguments integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) @@ -1287,7 +1167,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) if(.not.ccohort_hydr%is_newly_recruited) then csite_hydr%h2oveg = csite_hydr%h2oveg + & (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o*currentCohort%n endif @@ -1297,7 +1177,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) currentPatch => currentPatch%younger enddo !end patch loop - csite_hydr%h2oveg = csite_hydr%h2oveg / AREA + csite_hydr%h2oveg = csite_hydr%h2oveg*AREA_INV ! Note that h2oveg_dead is incremented wherever we have litter fluxes ! and it will be reduced via an evaporation term @@ -1323,7 +1203,6 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! After the root water uptake, is_newly_recruited flag is set to false. ! ---------------------------------------------------------------------------------- - use EDTypesMod, only : AREA ! Arguments integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) @@ -1364,9 +1243,9 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) roota = EDPftvarcon_inst%roota_par(ft) rootb = EDPftvarcon_inst%rootb_par(ft) recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n/AREA/dtime + denh2o*currentCohort%n*AREA_INV/dtime recruitw_total = recruitw_total + recruitw if( csite_hydr%nlevsoi_hyd == 1) then csite_hydr%recruit_w_uptake(1) = csite_hydr%recruit_w_uptake(1)+ & @@ -1409,7 +1288,6 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) ! This subroutine constrains the number of plants so that there is enought water ! for newly recruited individuals from the soil ! --------------------------------------------------------------------------- - use EDTypesMod, only : AREA ! Arguments type(ed_site_type), intent(inout), target :: csite @@ -1420,8 +1298,8 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) type(ed_cohort_hydr_type), pointer :: ccohort_hydr type(ed_site_hydr_type), pointer :: csite_hydr real(r8) :: tmp1 - real(r8) :: watres_local !minum water content - real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3) + real(r8) :: watres_local !minum water content [m3/m3] + real(r8) :: total_water !total water in rhizosphere at a specific layer (m^3 ha-1) real(r8) :: total_water_min !total minimum water in rhizosphere at a specific layer (m^3) real(r8) :: roota !root distriubiton parameter a real(r8) :: rootb !root distriubiton parameter b @@ -1436,7 +1314,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) csite_hydr => csite%si_hydr ccohort_hydr =>ccohort%co_hydr recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - sum(ccohort_hydr%th_troot(:)*ccohort_hydr%v_troot(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o @@ -1468,12 +1346,9 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) case default end select - total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) * & - csite_hydr%l_aroot_layer(j)/& - bc_in %dz_sisl(j) - total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) * & - csite_hydr%l_aroot_layer(j)/& - bc_in %dz_sisl(j) + total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) + total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) + !assumes that only 50% is available for recruit water.... recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) @@ -1522,7 +1397,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! the same. ! ! !USES: - use EDTypesMod , only : AREA + ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -1535,12 +1410,12 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) type(ed_cohort_type) , pointer :: cCohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] + ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the - ! innermost shell radius is less than the assumed - ! absorbing root radius rs1 - ! 1.e-5_r8 from Rudinger et al 1994 + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 integer :: nlevsoi_hyd !----------------------------------------------------------------------- @@ -1572,9 +1447,6 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) enddo - !update the conductitivity for first soil shell is done at subroutine KmaxInnerShell - !which is dependant on whether it is water uptake or loss for every 30 minutes - do j = 1,csite_hydr%nlevsoi_hyd hksat_s = bc_in%hksat_sisl(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa @@ -1583,7 +1455,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then k_inner = 1 - + ! Set the max conductance on the inner shell first. If the node radius ! on the shell is smaller than the root radius, just set the max conductance ! to something extremely high. @@ -1626,8 +1498,6 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) ! ! !USES: - use EDTypesMod , only : AREA - ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -1666,7 +1536,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) real(r8) :: v_rhiz(nlevsoi_hyd_max) ! updated volume of all rhizosphere compartments [m3] real(r8) :: r_delta ! change in radius of innermost rhizosphere compartment [m] real(r8) :: dpsidr ! water potential gradient near root surface [MPa/m] - real(r8) :: w_shell_new ! updated water mass in rhizosphere compartment [kg] + real(r8) :: w_shell_new ! updated water volume in rhizosphere compartment [m3] real(r8) :: w_layer_init(nlevsoi_hyd_max) ! initial water mass by layer [kg] real(r8) :: w_layer_interp(nlevsoi_hyd_max) ! water mass after interpolating to new rhizosphere [kg] real(r8) :: w_layer_new(nlevsoi_hyd_max) ! water mass by layer after interpolation and fudging [kg] @@ -1805,11 +1675,10 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) w_layer_interp(j) = 0._r8 v_rhiz(j) = 0._r8 do k = 1,nshell - w_layer_init(j) = w_layer_init(j) + denh2o/bc_in%dz_sisl(j) * & - ( csite_hydr%l_aroot_layer_init(j) * & - csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) - w_layer_interp(j) = w_layer_interp(j) + denh2o/bc_in%dz_sisl(j) * & - ( csite_hydr%l_aroot_layer(j)*csite_hydr%v_shell(j,k) * & + w_layer_init(j) = w_layer_init(j) + denh2o * & + (csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) + w_layer_interp(j) = w_layer_interp(j) + denh2o * & + (csite_hydr%v_shell(j,k) * & (s_shell_interp(j,k)*(bc_in%watsat_sisl(j)-bc_in%watres_sisl(j))+bc_in%watres_sisl(j)) ) v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) enddo @@ -1821,8 +1690,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) do j = 1,csite_hydr%nlevsoi_hyd ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * & - denh2o*csite_hydr%l_aroot_layer(j)/bc_in%dz_sisl(j) ) - bc_in%watres_sisl(j)) / & + delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j)) / & (bc_in%watsat_sisl(j)-bc_in%watres_sisl(j)) end if !has l_aroot_coh changed? enddo @@ -1837,10 +1705,10 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & ( bc_in%watsat_sisl(j)-bc_in%watres_sisl(j) ) + bc_in%watres_sisl(j) w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & - csite_hydr%v_shell(j,k) * denh2o + csite_hydr%v_shell(j,k) w_layer_new(j) = w_layer_new(j) + w_shell_new enddo - h2osoi_liq_col_new(j) = w_layer_new(j)/( v_rhiz(j)/bc_in%dz_sisl(j) ) + h2osoi_liq_col_new(j) = w_layer_new(j)/ v_rhiz(j) end if !has l_aroot_coh changed? enddo @@ -1935,7 +1803,6 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) ! shell until the change in mean layer water (dwat_kgm2) is accounted for. ! ! !USES: - use EDtypesMod , only : AREA ! ! !ARGUMENTS: integer, intent(in) :: nsites @@ -1976,8 +1843,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) csite_hydr => sites(s)%si_hydr do j = 1,csite_hydr%nlevsoi_hyd - cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) & - / bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) * denh2o/AREA + cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV if(csite_hydr%nlevsoi_hyd == 1) then dwat_kgm2 = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - cumShellH2O @@ -2019,9 +1885,8 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) / & - bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) - wdiff = thdiff * v_cum * denh2o + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) if(abs(dwat_kg) >= abs(wdiff)) then csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) dwat_kg = dwat_kg - wdiff @@ -2034,8 +1899,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) enddo if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) / bc_in(s)%dz_sisl(j) * & - csite_hydr%l_aroot_layer(j) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) thdiff = dwat_kg / v_cum / denh2o do k = nshell, 1, -1 csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff @@ -2044,14 +1908,14 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) ! m3/m3 * Total volume m3 * kg/m3 = kg h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) / bc_in(s)%dz_sisl(j) * csite_hydr%l_aroot_layer(j) * denh2o + csite_hydr%v_shell(j,:) * denh2o enddo ! balance check if(csite_hydr%nlevsoi_hyd .ne. 1) then do j = 1,csite_hydr%nlevsoi_hyd - errh2o(j) = sum(h2osoi_liq_shell(j,:))/AREA - bc_in(s)%h2o_liq_sisl(j) + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) if (abs(errh2o(j)) > 1.e-9_r8) then found = .true. @@ -2064,7 +1928,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) end if enddo else - errh2o(csite_hydr%nlevsoi_hyd) = sum(h2osoi_liq_shell(csite_hydr%nlevsoi_hyd,:))/AREA - sum( bc_in(s)%h2o_liq_sisl(:) ) + errh2o(csite_hydr%nlevsoi_hyd) = sum(h2osoi_liq_shell(csite_hydr%nlevsoi_hyd,:))*AREA_INV - sum( bc_in(s)%h2o_liq_sisl(:) ) end if end do @@ -2090,7 +1954,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! !DESCRIPTION: !s ! !USES: - use EDTypesMod , only : AREA use FatesUtilsMod , only : check_var_real ! ARGUMENTS: @@ -2187,8 +2050,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: err_code = 0 logical, parameter :: weight_serial_dt = .false. ! For serial solver (1D), should - ! the fractional time each layer - ! gets, be weighted by conductance? + ! the fractional time each layer + ! gets, be weighted by conductance? ! ---------------------------------------------------------------------------------- @@ -2231,7 +2094,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) transp_col = 0.0_r8 do while (associated(cpatch)) ifp = ifp + 1 - patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area/AREA) + patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area*AREA_INV) transp_col = transp_col + bc_in(s)%qflx_transp_pa(ifp)*patch_wgt cpatch => cpatch%younger end do @@ -2345,11 +2208,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) else kmax_up = cohort_hydr%kmax_aroot_radial_out(j) end if - + ! Get matric potential [Mpa] of the absorbing root call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+2), & ccohort_hyd%th_aroot(j), psi_aroot, site_hydr, bc_in) - + ! Get Fraction of Total Conductivity [-] of the absorbing root call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+2), & psi_aroot, ftc_aroot, site_hydr, bc_in) @@ -2359,17 +2222,17 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) r_shells = 1._r8/(kmax_aroot*ftc_aroot) ! Path is between rhizosphere shells - + do i = 1,nshell - + kmax_up = site_hydr%kmax_outer_shell(j,i) kmax_lo = site_hydr%kmax_inner_shell(j,i) - + call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+3), & site_hydr%h2osoi_liqvol_shell(j,i), psi_shell, site_hydr, bc_in) call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+3), & psi_shell, ftc_shell, site_hydr, bc_in) - + r_shells = r_shells + 1._r8/(kmax_lo*ftc_shell) if(i ccohort%shorter - enddo !cohort - - cpatch => cpatch%younger - enddo !patch + ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j), & + site_hydr, bc_in(s)) + end do - ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) - site_hydr%supsub_flag(:) = 999 - do j=1,site_hydr%nlevsoi_hyd - !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter - ! introduced for the van Genuchten, but does not exist for Campbell SWC. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! watres_local = bc_in(s)%watres_sisl(j) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & + ccohort => ccohort%shorter + enddo !cohort + + cpatch => cpatch%younger + enddo !patch + + ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) + site_hydr%supsub_flag(:) = 999 + do j=1,site_hydr%nlevsoi_hyd + !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter + ! introduced for the van Genuchten, but does not exist for Campbell SWC. + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! watres_local = bc_in(s)%watres_sisl(j) + case (campbell) + call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & (-1._r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & bc_in(s)%bsw_sisl(j), & tmp1) - call swcCampbell_th_from_satfrac(tmp1, & + call swcCampbell_th_from_satfrac(tmp1, & bc_in(s)%watsat_sisl(j), & watres_local) - case default - end select - do k=1,nshell - if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & + case default + end select + do k=1,nshell + if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & (bc_in(s)%watsat_sisl(j)-small_theta_num)) then site_hydr%supsub_flag(j) = k site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & + else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & (watres_local+small_theta_num)) then site_hydr%supsub_flag(j) = -k site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num - else + else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & - dth_layershell_col(j,k) - end if - enddo - - ! Update the matric potential in the inner-most shell - ! (used for setting tissue potentials of new recruits) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), smp) - site_hydr%psisoi_liq_innershell(j) = smp - - !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) - bc_out(s)%qflx_soil2root_sisl(j) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:)) * & - site_hydr%l_aroot_layer(j)/bc_in(s)%dz_sisl(j)/AREA*denh2o/dtime)+ & - site_hydr%recruit_w_uptake(j) - - ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) - - ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j) - - enddo !site_hydr%nlevsoi_hyd - - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks - - !remove the recruitment water uptake as it has been added to prev_h2oveg - - totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & - site_hydr%recruit_w_uptake(:))*dtime - - total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) - - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e - - bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & - site_hydr%h2oveg_growturn_err - & - site_hydr%h2oveg_pheno_err-& - site_hydr%h2oveg_hydro_err - + dth_layershell_col(j,k) + end if + enddo + + ! Update the matric potential in the inner-most shell + ! (used for setting tissue potentials of new recruits) + call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & + bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%bsw_sisl(j), smp) + site_hydr%psisoi_liq_innershell(j) = smp + + !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) + bc_out(s)%qflx_soil2root_sisl(j) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & + site_hydr%recruit_w_uptake(j) + + ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & + ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + + ! Save the amount of liquid soil water known to the model after root uptake + ! This calculation also assumes that 1mm of water is 1kg + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j) + + enddo !site_hydr%nlevsoi_hyd + + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks + + !remove the recruitment water uptake as it has been added to prev_h2oveg + + totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & + site_hydr%recruit_w_uptake(:))*dtime + + total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) + + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e + + bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & + site_hydr%h2oveg_growturn_err - & + site_hydr%h2oveg_pheno_err-& + site_hydr%h2oveg_hydro_err + enddo !site @@ -2564,6 +2426,763 @@ end subroutine Hydraulics_BC ! ===================================================================================== + + subroutine UpdatePlantKMax(ccohort_hydr,ccohort,csite_hydr,bc_in) + + ! --------------------------------------------------------------------------------- + ! + ! This routine sets the maximum conductance of all compartments in the plant, from + ! leaves, to stem, to transporting root, to the absorbing roots. + ! These properties are dependent only on the materials (conductivity) and the + ! geometry of the compartments. + ! The units of all K_max values are [kg H2O s-1 MPa-1] + ! + ! There are some different ways to represent overall conductance from node-to-node + ! throughout the hydraulic system. Universally, all can make use of a system + ! where we separate the hydraulic compartments of the nodes into the upper (closer + ! to the sky) and lower (away from the sky) portions of the compartment. It is + ! possible that due to things like xylem taper, the two portions may have different + ! conductivity, and therefore differnet conductances. + ! + ! Assumption 0. This routine calculates maximum conductivity for 1 plant. + ! Assumption 1. The compartment volumes, heights and lengths have all been + ! determined, probably called just before this routine. + ! + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! --------------------------------------------------------------------------------- + + ! Arguments + + type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr + type(ed_cohort_type),intent(in),target :: ccohort + type(ed_site_hydr_type),intent(in),target :: csite_hydr + type(bc_in_type),intent(in) :: bc_in + + + + ! Locals + integer :: k ! Compartment (node) index + integer :: k_ag ! Compartment index for above-ground indexed array + integer :: pft ! Plant Functional Type index + real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] + real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] + real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] + real(r8) :: z_node ! distance between compartment center and mph [m] + real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] + real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways + ! [kg-1 s MPa] + real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + ! from the absorbing roots center nodes to the + ! transporting root center node + real(r8) :: rootfr ! fraction of absorbing root in each soil layer + ! assumes propotion of absorbing root is equal + ! to proportion of total root + real(r8) :: kmax_layer ! max conductance between transporting root node + ! and absorbing root node in each layer [kg s-1 MPa-1] + real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each + ! soil layer [m2] + + real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] + + + pft = ccohort%pft + + ! Get the cross-section of the plant's sapwood area [m2] + call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) + + + ! Leaf Maximum Hydraulic Conductance + ! The starting hypothesis is that there is no resistance inside the + ! leaf, between the petiole and the center of storage. To override + ! this, make provisions by changing the kmax to a not-absurdly high + ! value. It is assumed that the conductance in this default case, + ! is regulated completely by the stem conductance from the stem's + ! center of storage, to the petiole. + + ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 + + + ! Stem Maximum Hydraulic Conductance + + do k=1, n_hypool_stem + + ! index for "above-ground" arrays, that contain stem and leaf + ! in one vector + k_ag = k+n_hypool_leaf + + ! Depth from the petiole to the lower, node and upper compartment edges + + z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) + z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) + z_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_upper_ag(k_ag) + + + ! Then we calculate the maximum conductance from each the lower, node and upper + ! edges of the compartment to the petiole. The xylem taper factor requires + ! that the kmax it is scaling is from the point of interest to the mean height + ! of the petioles. Then we can back out the conductance over just the path + ! of the upper and lower compartments, but subtracting them as resistors in + ! series. + + ! max conductance from upper edge to mean petiole height + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_upper) * & + a_sapwood / z_upper + + ! max conductance from node to mean petiole height + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_node) * & + a_sapwood / z_node + + ! max conductance from lower edge to mean petiole height + kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_lower) * & + a_sapwood / z_lower + + ! Max conductance over the path of the upper side of the compartment + ccohort_hydr%kmax_stem_upper(k_ag) = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 + + ! Max conductance over the path on the loewr side of the compartment + ccohort_hydr%kmax_stem_lower(k_ag) = (1._r8/kmax_lower - 1._r8/kmax_node)**-1._r8 + + + enddo + + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) + + z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) + z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot + + + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_node) * & + a_sapwood / z_node + + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(taper_exponent, z_upper) * & + a_sapwood / z_upper + + ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**-1._r8 + + + ! The maximum conductance between the center node of the transporting root + ! compartment, and the center node of the absorbing root compartment, is calculated + ! as a residual. Specifically, we look at the total resistance the plant has in + ! the stem so far, by adding those resistances in series. + ! Then we use a parameter to specify what fraction of the resistance + ! should be below-ground between the transporting root node and the absorbing roots. + ! After that total is calculated, we then convert to a conductance, and split the + ! conductance in parallel between root layers, based on the root fraction. + ! Note* The inverse of max conductance (KMax) is minimum resistance: + + + rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & + sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & + sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & + 1._r8/kmax_troot_upper + + ! Calculate the residual resistance below ground, as a resistor + ! in series with the existing above ground + ! Invert to find below-ground kmax + kmax_bg = 1._r8/(rmin_ag * (1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) + + ! The max conductance of each layer is in parallel, therefore + ! the kmax terms of each layer, should sum to kmax_bg + do j=1,nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + end if + + kmax_layer = rootfr*kmax_bg + + ! Two transport pathways, in two compartments exist in each layer. + ! These pathways are connected in serial. + ! For simplicity, we simply split the resistance between the two. + ! Mathematically, this results in simply doubling the conductance + ! and applying to both paths. Here are the two paths: + ! 1) is the path between the transporting root's center node, to + ! the boundary of the transporting root with the boundary of + ! the absorbing root (kmax_troot_lower) + ! 2) is the path between the boundary of the absorbing root and + ! transporting root, with the absorbing root's center node + ! (kmax_aroot_upper) + + ccohort_hydr%kmax_troot_lower(j) = 2.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_upper(j) = 2.0_r8 * kmax_layer + + end do + + ! Finally, we calculate maximum radial conductance from the root + ! surface to its center node. This transport is not a xylem transport + ! like the calculations prior to this. This transport is through the + ! exodermis, cortex, casparian strip and endodermis. The actual conductance + ! will possibly depend on the potential gradient (whether out-of the root, + ! or in-to the root). So we calculate the kmax's for both cases, + ! and save them for the final conductance calculation. + + do j=1,nlevsoi_hyd + + ! Surface area of the absorbing roots for this cohort in this layer [m2] + surfarea_aroot_layer = 2._r8 * pi_const *csite_hydr%rs1(j) * ccohort_hydr%l_aroot_layer(j) + + ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] + ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer + + ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + + end do + + + return + end subroutine UpdatePlantKMax + + ! =================================================================================== + + subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top,d_th_node,sapflow,rootuptake,wb_err) + + ! ------------------------------------------------------------------------------- + ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and + ! the list need not be across the whole path from stomata to the last rhizosphere shell, but + ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. + ! ------------------------------------------------------------------------------- + + ! !ARGUMENTS + type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr + type(ed_site_hydr_type), intent(in),target :: site_hydr + integer , intent(in) :: ilayer ! soil layer index of interest + real(r8) , intent(in) :: psi_node(:) ! matric potential of nodes [Mpa] + real(r8) , intent(in) :: flc_node(:) ! fractional loss of conductivity at water storage nodes [-] + real(r8) , intent(in) :: dt_step ! time [seconds] over-which to calculate solution + real(r8) , intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + real(r8),intent(out) :: d_th_node(n_hypool_tot) ! change in theta over the timestep + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: wb_err ! transpiration should match change in storage [kg] + + ! Locals + + integer :: inode ! node index "i" + integer :: jpath ! path index "j" + integer :: ishell ! rhizosphere shell index of the node + integer :: i_dn ! downstream node of current flow-path + integer :: i_up ! upstream node of current flow-path + integer :: iter ! iteration count for sub-steps + logical :: solution_found ! logical set to true if a solution was found within error tolerance + real(r8) :: kmax_up ! maximum conductance of the upstream half of path [kg s-1 Mpa-1] + real(r8) :: kmax_dn ! maximum conductance of the downstream half of path [kg s-1 MPa-1] + real(r8) :: wb_step_err + real(r8) :: wb_err ! sum of water balance error over substeps + real(r8) :: leaf_water ! kg of water in the leaf + real(r8) :: stem_water ! kg of water in the stem + real(r8) :: root_water ! kg of water in the transp and absorbing roots + real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] + real(r8) :: th_node(n_hypool_tot) + real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] + real(r8) :: v_node(n_hypool_tot) ! volume of the node [m3] + real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] + real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] + real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] + real(r8) :: dftc_dtheta_node(n_hypool_tot) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(n_hypool_tot) ! deriv psi w.r.t. theta + real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] + real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] + real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] + real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_r(n_hypool_tot) + real(r8) :: rootfrac_plant ! This is the fraction of absorbing root from one plant + ! out of the total absorbing roots from the whole community of plants, + + + integer, parameter :: max_iter = 5 + real(r8), parameter :: max_wb_step_err = 1.e-6_r8 + real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] + + ! ------------------------------------------------------------------------------- + ! Part 1. Calculate node quantities: + ! matric potential: psi_node + ! fraction of total conductance: ftc_node + ! total potential (matric + elevatio) h_node + ! deriv. ftc wrt theta: dftc_dtheta_node + ! deriv. psi wrt theta: dpsi_dtheta_node + ! ------------------------------------------------------------------------------- + + + ! This is the fraction of total absorbing root length that a prototype + ! plant for this cohort takes up. Note: + ! ccohort_hydr%l_aroot_layer(ilayer) is units [m/plant] + ! site_hydr%l_aroot_layer(ilayer) is units [m/site] + + froot_frac_plant = ccohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + + + ! For all nodes leaf through rhizosphere + ! Send node heights and compartment volumes to a node-based array + + do inode = 1,n_hypool_tot + + if (inode<=n_hypool_ag) then + z_node(inode) = ccohort_hydr%z_node_ag(inode) + v_node(inode) = ccohort_hydr%v_node_ag(inode) + th_node_init(inode) = ccohort_hydr%th_ag(inode) + elseif (inode==n_hypool_ag+1) then + z_node(inode) = ccohort_hydr%z_node_troot + v_node(inode) = ccohort_hydr%v_troot + th_node_init(inode) = ccohort_hydr%th_troot + elseif (inode==n_hyppol_ag+2) then + z_node(inode) = bc_in(s)%z_sisl(ilayer) + v_node(inode) = ccohort_hydr%v_aroot_layer(:) + th_node_init(inode) = ccohort_hyd%th_aroot(ilayer) + else + ishell = inode-(n_hypool_tot+2) + z_node(inode) = bc_in(s)%z_sisl(ilayer) + ! The volume of the Rhizosphere for a single plant + v_node(inode) = csite_hydr%v_shell(ilayer,ishell)*froot_frac_plant + th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) + end if + + end do + + + ! Outer iteration loop + ! This cuts timestep in half and resolve the solution with smaller substeps + ! This loop is cleared when the model has found a solution + + solution_found = .false. + iter = 0 + do while( .not.solution_found ) + + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps + + sapflow = 0._r8 + rootuptake = 0._r8 + wb_err = 0._r8 + + ! Gracefully quit if too many iterations have been used + if(iter>max_iter)then + write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' + write(fates_log(),*) '' + leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & + ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + root_water = (ccohort_hydr%th_troot*ccohort_hydr%v_troot) + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',ccohort%dbh + write(fates_log(),*) 'pft: ',ccohort%pft + write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) + + + ! Determine how many substeps, and how long they are + + nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. + + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds + + ! Walk through sub-steps + do istep = 1,nsteps + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + + ! Calculate on-node quantities: potential, and derivatives + do inode = 1,n_hypool_tot + + ! Get matric potential [Mpa] + call psi_from_th(currentCohort%pft, porous_media(inode), th_node(inode), & + psi_node(inode), site_hydr, bc_in) + + ! Get total potential [Mpa] + h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + + ! Get Fraction of Total Conductivity [-] + call flc_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + ftc_node(inode), site_hydr, bc_in) + + ! deriv ftc wrt theta + call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & + dpsi_dtheta_node(inode), site_hydr, bc_in) + + call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + dftc_dpsi, site_hydr, bc_in) + + dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) + + end do + + + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- + + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- + + jpath = 1 + i_dn = 1 + i_up = 2 + kmax_dn = cohort_hydr%kmax_petiole_to_leaf + kmax_up = cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do jpath=2,n_hypool_ag-1 + + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) + kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + end do + + + ! Path is between lowest stem and transporting root + + jpath = n_hypool_ag + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) + kmax_lo = cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between the transporting root + ! and the absorbing root for this layer + + jpath = n_hypool_ag+1 + i_dn = jpath + i_up = jpath+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + jpath = n_hypool_ag+2 + i_dn = jpath + i_up = jpath+1 + + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) + else + kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) + end if + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*root_frac_plant + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + ! Path is between rhizosphere shells + + do jpath = n_hypool_ag+3,n_hpool_tot-1 + + i_dn = jpath + i_up = jpath+1 + ishell_dn = i_dn - (n_hypool_ag+2) + ishell_up = i_up - (n_hypool_ag+2) + kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up)*root_frac_plant + kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo)*root_frac_plant + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta(i_up), dftc_dtheta(i_dn), & + dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + k_eff(jpath), & + A_term(jpath), & + B_term(jpath)) + + + end do + + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- + + tris_a(1) = 0._r8 + tris_b(1) = A_term(1) - denh20*vol_node(1)/dt_substep + tris_c(1) = B_term(1) + tris_r(1) = q_top - k_eff(1)*(h_node(2)-h_node(1)) + + + do inode = 2,n_hypool_tot-1 + jpath = inode + tris_a(inode) = -A_term(jpath-1) + tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_c(inode) = B_term(jpath) + tris_r(inode) = -k_eff(jpath)*(h_node(inode+1)-h_node(inode)) + & + k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + + end do + + inode = n_hypool_tot + jpath = n_hypool_tot + tris_a(inode) = -A_term(jpath-1) + tris_b(inode) = -B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_c(inode) = 0._r8 + tris_r(inode) = k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + + + ! Calculate the change in theta + + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) + + + ! Catch super-saturated and sub-residual water contents + + ! Mass error (flux - change) + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_end = sum((th_node(:)+dth_node(:))*v_node(:))*denh2o + + wb_step_err = (q_top*dt_substep) - (w_tot_beg-w_tot_end) + + if(abs(wb_step_err)>max_wb_step_err)then + solution_found = .false. + exit + else + ! Note: this is somewhat of a default true. And the sub-steps + ! will keep going unless its changed and broken out of + ! the loop. + solution_found = .true. + end if + + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator + + th_node(:) = th_node(:) + dth_node(:) + + ! Accumulate the water balance error for diagnostic purposes + wb_err = wb_err + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + inode = n_hypool_ag + sapflow = sapflow + dt_substep * & + (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) + A_term(inode)*dth_node(inode) + & ! dq at node i + B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + inode = h_hypool_ag+2 + rootuptake = rootuptake + dt_substep * & + (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) + A_term(inode)*dth_node(inode) + & ! dq at node i + B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + + + end do ! do istep = 1,nsteps (substep loop) + + iterh1=iterh1+1 + + end do + + ! Save the number of times we refined our sub-step counts (iterh1) + ccohort_hydr%iterh1 = real(iterh1) + ! Save the number of sub-steps we ultimately used + ccohort_hydr%iterh2 = real(nsteps) + + ! ----------------------------------------------------------- + ! To a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err) > max_wb_err ) then + + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err + write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' + + leaf_water = ccohort_hydr%th_ag(1)*ccohort_hydr%v_ag(1)*denh2o + stem_water = sum(ccohort_hydr%th_ag(2:n_hypool_ag) * & + ccohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',ccohort%dbh + write(fates_log(),*) 'pft: ',ccohort%pft + write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Adjust final water balance by adding back in the error term + ! ------------------------------------------------------------ + + w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg + dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep + we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep + we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual + if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then + if(debug) then + write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' + endif + !dump the error water to the bin with largest water storage + max_l = maxloc(th_node(:)*v_node(:),dim=1) + th_node(max_l) = th_node(max_l)- & + we_tot_outer/(v_node(max_l)*denh2o) + th_node(max_l) = min (th_node(max_l),& + ths_node(max_l)-small_theta_num) + th_node(max_l) = max(th_node(max_l),& + thr_node(max_l)+small_theta_num) + w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg + dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep + we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep + we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual + end if + + + + ! If we have made it to this point, supposedly we have completed the whole time-step + ! for this cohort x layer combination. It is now safe to save the delta theta + ! value and pass it back to the calling routine. The value passed back is the + ! change in theta over all sub-steps. + + dth_node(:) = th_node(:)-th_node_init(:) + + + + return + end subroutine ImTaylorSolverTermsCond1D + + ! ================================================================================= + + subroutine GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_up,ftc_dn, & + h_up,h_dn, & + dftc_dtheta_up, dftc_dtheta_dn, & + dpsi_dtheta_up, dpsi_dtheta_dn, & + k_eff, & + A_term, & + B_term) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction from upstream node to downstream node. + ! ----------------------------------------------------------------------------- + + real(r8),intent(in) :: kmax_up, kmax_dn ! max conductance [kg s-1 Mpa-1] + real(r8),intent(in) :: ftc_up, ftc_dn ! frac total conductance [-] + real(r8),intent(in) :: h_up, h_dn ! total potential [Mpa] + real(r8),intent(in) :: dftc_dtheta_up, dftc_dtheta_dn ! Derivative + ! of FTC wrt relative water content + + real(r8),intent(in) :: dpsi_dtheta_up, dpsi_dtheta_dn ! Derivative of matric potential + ! wrt relative water content + + real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(in) :: a_term ! "A" term for path (See tech note) + real(r8),intent(in) :: b_term ! "B" term for path (See tech note) + + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_dn*kmax_dn)+1._r8/(ftc_up*kmax_up)) + + ! Calculate difference in total potential over the path [MPa] + h_diff = h_up - h_dn + + ! "A" term, which operates on the down-stream node + A_term = (k_eff**2.0_r8) * h_diff * (kmax_dn**-1.0_r8) * (ftc_dn**-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + + ! "B" term, which operates on the up-stream node + B_term = (k_eff**2.0_r8) * h_diff * (kmax_up**-1.0_r8) * (ftc_up**-2.0_r8) & + * dftc_dtheta_up + k_eff * dpsi_dtheta_up + + + + return + end subroutine GetImTaylorKAB + + subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) ! --------------------------------------------------------------------------- @@ -2573,7 +3192,6 @@ subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) ! In another routine, this pool is reduced as water vapor flux, and ! passed to the HLM. ! --------------------------------------------------------------------------- - use EDTypesMod , only : AREA ! Arguments @@ -2590,9 +3208,9 @@ subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) ccohort_hydr => ccohort%co_hydr csite_hydr => csite%si_hydr delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*delta_n/AREA + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*delta_n*AREA_INV csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w @@ -2616,7 +3234,6 @@ subroutine RecruitWaterStorage(nsites,sites,bc_out) ! plant_stored_h2o_si will include this water when calculated in hydraulics_bc ! at the next timestep, when it gets pulled from the soil water. ! --------------------------------------------------------------------------- - use EDTypesMod, only : AREA ! Arguments integer, intent(in) :: nsites @@ -2653,7 +3270,7 @@ subroutine RecruitWaterStorage(nsites,sites,bc_out) currentPatch => currentPatch%younger enddo !end patch loop - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit / AREA + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit * AREA_INV end do @@ -2664,16 +3281,16 @@ end subroutine RecruitWaterStorage !--------------------------------------------------------------------------------------! subroutine GetK(K_max,FLC,K,h_diff,inode_up,inode_low) - + ! This subroutine determines the conductance of water between two nodes. ! The nodes may be between leaves, between leaf and stem, between stems, ! between - - - + + + return end subroutine GetK @@ -2681,7 +3298,7 @@ end subroutine GetK subroutine GetKMax() - + return @@ -2698,7 +3315,6 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, & site_hydr, bc_in) - use EDTypesMod , only : AREA ! ! !DESCRIPTION: ! @@ -2888,21 +3504,21 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k ! SET BOUNDARY PRESSURE DIFFERENCES & CONDUCTANCES !! compute water potential differences + conductances and their derivatives wrt water potential call boundary_hdiff_and_k( n_hypool_tot-nshell, & ! where the boundary occurs between root and soil (absorbing root node) - z_node, & ! elevation of all compartments [m] - psi_node, & ! water potential in compartment [Mpa] - flc_node, & ! frac loss conductivity [kg s-1 Mpa-1] - dflcdpsi_node, & ! change in FLC per change in water potential [kg s-1 Mpa-2] - kmax_bound, & ! max conductance at lower boundary of node [kg s-1 Mpa-1] - kmax_upper, & - kmax_lower, & - hdiff_bound, & ! out: difference in potential across nodes [Mpa] - k_bound, & - dhdiffdpsi0, & - dhdiffdpsi1, & - dkbounddpsi0, & - dkbounddpsi1, & - kmax_bound_aroot_soil1, & - kmax_bound_aroot_soil2) + z_node, & ! elevation of all compartments [m] + psi_node, & ! water potential in compartment [Mpa] + flc_node, & ! frac loss conductivity [kg s-1 Mpa-1] + dflcdpsi_node, & ! change in FLC per change in water potential [kg s-1 Mpa-2] + kmax_bound, & ! max conductance at lower boundary of node [kg s-1 Mpa-1] + kmax_upper, & + kmax_lower, & + hdiff_bound, & ! out: difference in potential across nodes [Mpa] + k_bound, & + dhdiffdpsi0, & + dhdiffdpsi1, & + dkbounddpsi0, & + dkbounddpsi1, & + kmax_bound_aroot_soil1, & + kmax_bound_aroot_soil2) ! SET BOUNDARY FLUX TERMS !! compute flux terms and their derivatives wrt water content @@ -3012,7 +3628,7 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k ! we_vol_inner ! different water balance metrics can be chosen here (with an appropriate corresponding thresh) - we_local = we_tot_inner*cCohort%n/AREA + we_local = we_tot_inner*cCohort%n*AREA_INV end do ! loop over sub-timesteps @@ -3037,7 +3653,7 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' @@ -3054,7 +3670,7 @@ subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, k dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then + if(abs(we_tot_outer*cCohort%n)*AREA_INV>1.0e-7_r8) then if(debug) then write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' endif @@ -3132,7 +3748,7 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) else err = abs(r(k) - a(k)*u(k-1)+b(k)*u(k)+c(k)*u(k+1)) end if - + rel_err = abs(u(k)/err) if(rel_err > allowable_rel_err)then @@ -3233,8 +3849,8 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps end subroutine boundary_hdiff_and_k ! - - + + @@ -4774,7 +5390,7 @@ end function zeng2001_crootfr ! ===================================================================================== -subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) +subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) ! ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. ! As fine root biomass (and thus absorbing root length) increases, this characteristic @@ -4785,20 +5401,22 @@ subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) ! ! !ARGUMENTS: -real(r8) , intent(in) :: l_aroot -real(r8) , intent(in) :: rs1 -real(r8) , intent(in) :: area -real(r8) , intent(in) :: dz -real(r8) , intent(out) :: r_out_shell(:) -real(r8) , intent(out) :: r_node_shell(:) -real(r8) , intent(out) :: v_shell(:) ! volume of a single rhizosphere shell +real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots +! for the whole site, this layer (m) +real(r8) , intent(in) :: rs1 ! Fine root radius (m) +real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) +real(r8) , intent(in) :: dz ! Width of current soil layer (m) +real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) +real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint +real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) +! for this layer ! ! !LOCAL VARIABLES: integer :: k ! rhizosphere shell indicies !----------------------------------------------------------------------- ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) -r_out_shell(nshell) = (pi_const*l_aroot/(area*dz))**(-0.5_r8) ! eqn(8) S98 +r_out_shell(nshell) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 if(nshell > 1) then do k = 1,nshell-1 r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 @@ -4806,26 +5424,34 @@ subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) end if ! set nodal (midpoint) radii of these shells -do k = 1,nshell -if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - ! r_node_shell(k) = 0.5_r8*(rs1 + r_out_shell(k)) -r_node_shell(k) = 0.5_r8*(r_out_shell(k)) -else +! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level +r_node_shell(k) = 0.5_r8*(rs1 + r_out_shell(k)) +!r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + +do k = 2,nshell r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) -end if enddo ! update volumes +if(voltype==bcvol)then do k = 1,nshell if(k == 1) then ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level - ! v_shell(k) = pi*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) -v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8) +v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) + else v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) end if enddo +elseif(voltype==rkvol)then +do k = 1,nshell +if(k == 1) then +v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) +else +v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) +end if +enddo +end if end subroutine shellGeom From 639e2dc7bbe502f8f8b68321191bc8fc98a811ac Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 31 Aug 2019 14:39:13 -0700 Subject: [PATCH 011/114] Removed deprecated FatesHydroSolversMod.F90 --- biogeophys/FatesHydroSolversMod.F90 | 12 ------------ 1 file changed, 12 deletions(-) delete mode 100644 biogeophys/FatesHydroSolversMod.F90 diff --git a/biogeophys/FatesHydroSolversMod.F90 b/biogeophys/FatesHydroSolversMod.F90 deleted file mode 100644 index 1219dd9aa7..0000000000 --- a/biogeophys/FatesHydroSolversMod.F90 +++ /dev/null @@ -1,12 +0,0 @@ -module FatesHydroSolversMod - - - -contains - - - - - - -end module FatesHydroSolversMod From 51e65f6554cb381f615d2d9134fd88af6a87e62a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 3 Sep 2019 10:08:02 -0700 Subject: [PATCH 012/114] More refactors of fates-hyro --- biogeochem/EDMortalityFunctionsMod.F90 | 6 +- biogeophys/FatesPlantHydraulicsMod.F90 | 153 +++++++++++++++++-------- main/FatesHydraulicsMemMod.F90 | 39 +++++-- main/FatesRestartInterfaceMod.F90 | 5 +- 4 files changed, 144 insertions(+), 59 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index eed631046a..8d83ece892 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -87,9 +87,9 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort ) hf_flc_threshold = EDPftvarcon_inst%hf_flc_threshold(cohort_in%pft) if(hlm_use_planthydro.eq.itrue)then !note the flc is set as the fraction of max conductivity in hydro - min_fmc_ag = minval(cohort_in%co_hydr%flc_ag(:)) - min_fmc_tr = minval(cohort_in%co_hydr%flc_troot(:)) - min_fmc_ar = minval(cohort_in%co_hydr%flc_aroot(:)) + min_fmc_ag = minval(cohort_in%co_hydr%ftc_ag(:)) + min_fmc_tr = cohort_in%co_hydr%ftc_troot + min_fmc_ar = minval(cohort_in%co_hydr%ftc_aroot(:)) min_fmc = min(min_fmc_ag, min_fmc_tr) min_fmc = min(min_fmc, min_fmc_ar) flc = 1.0_r8-min_fmc diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 9469f11380..1b98a54a26 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -70,6 +70,11 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: nshell use FatesHydraulicsMemMod, only: n_hypool_ag use FatesHydraulicsMemMod, only: porous_media + use FatesHydraulicsMemMod, only: leaf_p_media + use FatesHydraulicsMemMod, only: stem_p_media + use FatesHydraulicsMemMod, only: troot_p_media + use FatesHydraulicsMemMod, only: aroot_p_media + use FatesHydraulicsMemMod, only: rhiz_p_media use FatesHydraulicsMemMod, only: cap_slp use FatesHydraulicsMemMod, only: cap_int use FatesHydraulicsMemMod, only: cap_corr @@ -151,6 +156,7 @@ module FatesPlantHydraulicsMod public :: updateSizeDepTreeHydProps public :: updateWaterDepTreeHydProps public :: updateSizeDepTreeHydStates + public :: UpdateTreePsiFTCFromTheta public :: initTreeHydStates public :: updateSizeDepRhizHydProps public :: updateSizeDepRhizHydStates @@ -305,14 +311,14 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) type(ed_cohort_type), pointer :: cCohort type(ed_site_type), pointer :: csite type(ed_cohort_hydr_type), pointer :: ccohort_hydr - integer :: j,k,FT ! indices + integer :: j,k,ft ! indices real(r8) :: dz real(r8) :: smp cCohort => cc_p ccohort_hydr => cCohort%co_hydr csite => site_p - FT = cCohort%pft + ft = cCohort%pft !convert soil water contents to water potential in each soil layer and !assign it to the absorbing root (assume absorbing root water potential @@ -326,7 +332,11 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !ccohort_hydr%psi_aroot(j) = csite%si_hydr%psisoi_liq_innershell(j) ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equalibrium between soil and root - call th_from_psi(ft, 4, ccohort_hydr%psi_aroot(j), ccohort_hydr%th_aroot(j), csite%si_hydr, bc_in ) + call th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & + ccohort_hydr%th_aroot(j), csite%si_hydr, bc_in ) + call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & + ccohort_hydr%ftc_ag(j), csite%si_hydr, bc_in) + end do !initialize plant water potentials at hydrostatic equilibrium (dh/dz = 0) @@ -335,23 +345,31 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !it doesn't matter which absorbing root layer the transporting root water !potential is referenced to. - dz = ccohort_hydr%z_node_troot - ccohort_hydr%z_node_aroot(1) + dz = ccohort_hydr%z_node_troot - bc_in(s)%z_sisl(1) + ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 - call th_from_psi(ft, 3, ccohort_hydr%psi_troot, ccohort_hydr%th_troot, csite%si_hydr, bc_in) - + call th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, & + ccohort_hydr%th_troot, csite%si_hydr, bc_in) + call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 - call th_from_psi(ft, 2, ccohort_hydr%psi_ag(n_hypool_ag), ccohort_hydr%th_ag(n_hypool_ag), csite%si_hydr, bc_in) + call th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & + ccohort_hydr%th_ag(n_hypool_ag), csite%si_hydr, bc_in) + call flc_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & + ccohort_hydr%ftc_ag(n_hypool_ag)) + do k=n_hypool_ag-1, 1, -1 dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - 1.e-6_r8*denh2o*grav_earth*dz if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 - call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), ccohort_hydr%th_ag(k), csite%si_hydr, bc_in) + call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & + ccohort_hydr%th_ag(k), csite%si_hydr, bc_in) + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k),ccohort_hydr%ftc_ag(k)) end do ccohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 @@ -365,6 +383,48 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) end subroutine initTreeHydStates + + ! ===================================================================================== + + subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) + + ! This subroutine updates the potential and the fractional + ! of total conductivity based on the relative water + ! content + ! Arguments + type(ed_cohort_type),intent(inout), target :: ccohort + type(ed_site_hydr_type),intent(in), target :: csite_hydr + + ! Locals + integer :: ft ! Plant functional type + integer :: k ! loop index for compartments + integer :: j ! Loop index for soil layers + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + + ccohort_hydr => ccohort%co_hydr + ft = ccohort%pft + + ! Update Psi and FTC in above-ground compartments + ! ----------------------------------------------------------------------------------- + do k = 1,n_hypool_ag + call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), ccohort_hydr%psi_ag(k)) + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), ccohort_hydr%ftc_ag(k)) + end do + + ! Update the Psi and FTC for the transporting root compartment + k = n_hypool_ag+1 + call psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot, ccohort_hydr%psi_troot) + call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) + + ! Update the Psi and FTC for the absorbing roots + do j = 1, csite_hydr%nlevsoi_hyd + call psi_from_th(ft, aroot_p_media, ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j)) + call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), ccohort_hydr%ftc_aroot(j)) + end do + + return + end subroutine UpdateTreePsiFTCFromTheta ! ===================================================================================== @@ -383,8 +443,6 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) ! %z_lower_ag(:) ! %z_upper_ag(:) ! %z_node_troot - ! %z_lower_troot - ! %z_upper_troot ! %z_node_aroot(:) ! -------------------------------------------------------------------------------- @@ -815,6 +873,7 @@ function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) end function constrain_water_contents ! ===================================================================================== + subroutine CopyCohortHydraulics(newCohort, oldCohort) ! Arguments @@ -833,11 +892,9 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ! BC...PLANT HYDRAULICS - "constants" that change with size. ! Heights are referenced to soil surface (+ = above; - = below) ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag - ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag - ncohort_hydr%z_upper_troot = ocohort_hydr%z_upper_troot + ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag - ncohort_hydr%z_lower_troot = ocohort_hydr%z_lower_troot ncohort_hydr%kmax_lower = ocohort_hydr%kmax_lower ncohort_hydr%kmax_bound = ocohort_hydr%kmax_bound ncohort_hydr%kmax_treebg_tot = ocohort_hydr%kmax_treebg_tot @@ -846,7 +903,6 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init ncohort_hydr%v_troot = ocohort_hydr%v_troot ! quantities indexed by soil layer - ncohort_hydr%z_node_aroot = ocohort_hydr%z_node_aroot ncohort_hydr%kmax_treebg_layer = ocohort_hydr%kmax_treebg_layer ncohort_hydr%kmax_innershell = ocohort_hydr%kmax_innershell ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init @@ -856,8 +912,13 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ! BC PLANT HYDRAULICS - state variables ncohort_hydr%th_ag = ocohort_hydr%th_ag ncohort_hydr%th_troot = ocohort_hydr%th_troot + ncohort_hydr%th_aroot = ocohort_hydr%th_aroot ncohort_hydr%psi_ag = ocohort_hydr%psi_ag ncohort_hydr%psi_troot = ocohort_hydr%psi_troot + ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot + ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag + ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot + ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot ncohort_hydr%btran = ocohort_hydr%btran ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag @@ -866,21 +927,12 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%errh2o = ocohort_hydr%errh2o ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag - - - ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot - ! quantities indexed by soil layer - ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%qtop_dt = ocohort_hydr%qtop_dt - ncohort_hydr%dqtopdth_dthdt = ocohort_hydr%dqtopdth_dthdt ncohort_hydr%sapflow = ocohort_hydr%sapflow ncohort_hydr%rootuptake = ocohort_hydr%rootuptake @@ -925,15 +977,19 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call psi_from_th(currentCohort%pft, porous_media(k), ccohort_hydr%th_ag(k), & ccohort_hydr%psi_ag(k), site_hydr, bc_in) call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%flc_ag(k), site_hydr, bc_in) + ccohort_hydr%ftc_ag(k), site_hydr, bc_in) end do - call psi_from_th(currentCohort%pft, 3, ccohort_hydr%th_troot, & + call psi_from_th(currentCohort%pft, troot_p_media, ccohort_hydr%th_troot, & ccohort_hydr%psi_troot, site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, troot_p_media, ccohort_hydr%psi_troot, & + ccohort_hydr%ftc_troot, site_hydr, bc_in) do j=1,site_hydr%nlevsoi_hyd - call psi_from_th(currentCohort%pft, 4, ccohort_hydr%th_aroot(j), & + call psi_from_th(currentCohort%pft, aroot_p_media, ccohort_hydr%th_aroot(j), & ccohort_hydr%psi_aroot(j), site_hydr, bc_in) + call flc_from_psi(currentCohort%pft, aroot_p_media, ccohort_hydr%psi_aroot(j), & + ccohort_hydr%ftc_aroot(j), site_hydr, bc_in) end do call flc_gs_from_psi(currentCohort, ccohort_hydr%psi_ag(1)) @@ -2195,7 +2251,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kbg_tot = 0._r8 - do j=1,site_hydr%nlevsoi_hyd ! Path is between the absorbing root @@ -2204,9 +2259,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! potential gradient (same elevation, no geopotential ! required. if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then - kmax_up = cohort_hydr%kmax_aroot_radial_in(j) + kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) else - kmax_up = cohort_hydr%kmax_aroot_radial_out(j) + kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) end if ! Get matric potential [Mpa] of the absorbing root @@ -2222,11 +2277,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) r_shells = 1._r8/(kmax_aroot*ftc_aroot) ! Path is between rhizosphere shells - + froot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) do i = 1,nshell - kmax_up = site_hydr%kmax_outer_shell(j,i) - kmax_lo = site_hydr%kmax_inner_shell(j,i) + kmax_up = site_hydr%kmax_outer_shell(j,i)*froot_frac_plant + kmax_lo = site_hydr%kmax_inner_shell(j,i)*froot_frac_plant call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+3), & site_hydr%h2osoi_liqvol_shell(j,i), psi_shell, site_hydr, bc_in) @@ -2288,7 +2343,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Absorbing root ccohort_hyd%th_aroot(j) = ccohort_hyd%th_aroot(j) + dth_node(n_hypool_ag+2) - ! Calculate diagnostics dwat_veg_coh = & @@ -2311,30 +2365,42 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL dth_layershell_col(j,:) = dth_layershell_col(j,:) + & - dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & + dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * ccohort_hydr%l_aroot_layer(j) * & ccohort%n / site_hydr%l_aroot_layer(j) enddo !soil layer ! --------------------------------------------------------- - ! Update water potential of plant compartments + ! Update water potential and frac total conductivity + ! of plant compartments ! --------------------------------------------------------- ! Above ground do k=1,n_hypool_ag call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), & ccohort_hydr%psi_ag(k), site_hydr, bc_in(s) ) + + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & + ccohort_hydr%ftc_ag(k), site_hydr, bc_in(s)) + enddo ! Update water potential of transporting root compartment k = n_hpool_ag+1 call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot, & ccohort_hydr%psi_troot, site_hydr, bc_in(s)) + call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot, & + ccohort_hydr%ftc_troot, site_hydr, bc_in(s)) + ! Update water potential of absorbing root root compartment do j=1,site_hydr%nlevsoi_hyd call psi_from_th(ft, porous_media(n_hypool_ag+2), & ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j), & site_hydr, bc_in(s)) + call flc_from_psi(ft, porous_media(n_hypool_ag+2), & + ccohort_hydr%psi_aroot(j), ccohort_hydr%ftc_aroot(j), & + site_hydr, bc_in(s)) + end do ccohort => ccohort%shorter @@ -2683,6 +2749,7 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, real(r8) :: leaf_water ! kg of water in the leaf real(r8) :: stem_water ! kg of water in the stem real(r8) :: root_water ! kg of water in the transp and absorbing roots + real(r8) :: real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] real(r8) :: th_node(n_hypool_tot) real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] @@ -2928,7 +2995,7 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! Special case. Maximum conductance depends on the ! potential gradient (same elevation, no geopotential ! required. - if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then + if(h_node(i_dn) < h_node(i_up) ) then kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) else kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) @@ -3093,26 +3160,18 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! Adjust final water balance by adding back in the error term ! ------------------------------------------------------------ - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - if(abs(we_tot_outer*cCohort%n)/AREA>1.0e-7_r8) then + if( abs(wb_err*cCohort%n)*AREA_INV>1.0e-7_r8) then if(debug) then write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' endif !dump the error water to the bin with largest water storage max_l = maxloc(th_node(:)*v_node(:),dim=1) th_node(max_l) = th_node(max_l)- & - we_tot_outer/(v_node(max_l)*denh2o) + wb_err/(v_node(max_l)*denh2o) th_node(max_l) = min (th_node(max_l),& ths_node(max_l)-small_theta_num) th_node(max_l) = max(th_node(max_l),& thr_node(max_l)+small_theta_num) - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual end if @@ -3718,7 +3777,7 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) integer :: k ! index real(r8) :: err ! solution error, in units of [m3/m3] real(r8) :: rel_err ! relative error, normalized by delta theta - real(r8), parameter :: allowable_rel_err = 0.01_r8 + real(r8), parameter :: allowable_rel_err = 0.001_r8 !---------------------------------------------------------------------- bet = b(1) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 86518b70f2..9bfe95c2e5 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -34,7 +34,23 @@ module FatesHydraulicsMemMod integer, parameter, public :: n_hypool_tot = n_hypool_ag + n_hypool_troot + n_hypool_aroot + nshell ! vector indexing the type of porous medium over an arbitrary number of plant pools - integer, parameter, public, dimension(n_hypool_tot) :: porous_media = (/1,2,3,4,5,5,5,5,5/) + + integer, parameter, public :: leaf_p_media = 1 + integer, parameter, public :: stem_p_media = 2 + integer, parameter, public :: troot_p_media = 3 + integer, parameter, public :: aroot_p_media = 4 + integer, parameter, public :: rhiz_p_media = 5 + + ! This vector holds the identifiers for which porous media type is in the comaprtment + integer, parameter, public, dimension(n_hypool_tot) :: porous_media = (/leaf_p_media, & + stem_p_media, & + troot_p_media, & + aroot_p_media, & + rhiz_p_media, & + rhiz_p_media, & + rhiz_p_media, & + rhiz_p_media, & + rhiz_p_media /) ! number of previous timestep's leaf water potential to be retained integer, parameter, public :: numLWPmem = 4 @@ -174,8 +190,8 @@ module FatesHydraulicsMemMod real(r8) :: z_node_ag(n_hypool_ag) ! nodal height of stem and leaf compartments (positive) real(r8) :: z_upper_ag(n_hypool_ag) ! height of upper stem and leaf compartment boundaries (positive) real(r8) :: z_lower_ag(n_hypool_ag) ! height of lower stem and leaf compartment boundaries (positive) - real(r8) :: z_node_troot ! nodal height of transporting root (negative) - + real(r8) :: z_node_troot ! height of transporting root node + ! Maximum hydraulic conductances [kg H2O s-1 MPa-1] ! ---------------------------------------------------------------------------------- @@ -214,16 +230,21 @@ module FatesHydraulicsMemMod ! State variable, relative water content by volume (i.e. "theta") - real(r8) :: th_ag(n_hypool_ag) ! water in aboveground compartments [kgh2o/indiv] - real(r8) :: th_troot ! water in belowground compartments [kgh2o/indiv] + real(r8) :: th_ag(n_hypool_ag) ! water in aboveground compartments [kgh2o/indiv] + real(r8) :: th_troot ! water in belowground compartments [kgh2o/indiv] real(r8),allocatable :: th_aroot(:) ! water in absorbing roots [kgh2o/indiv] - ! State diagnostic, water potential - real(r8) :: psi_ag(n_hypool_ag) ! water potential in aboveground compartments [MPa] - real(r8) :: psi_troot ! water potential in belowground compartments [MPa] + ! Diagnostic, water potential + real(r8) :: psi_ag(n_hypool_ag) ! water potential in aboveground compartments [MPa] + real(r8) :: psi_troot ! water potential in belowground compartments [MPa] real(r8),allocatable :: psi_aroot(:) ! water potential in absorbing roots [MPa] + ! Diagnostic, fraction of total conductivity + real(r8) :: ftc_ag(n_hypool_ag) ! ... in above-ground compartments [-] + real(r8) :: ftc_troot ! ... in the transporting root [-] + real(r8),allocatable :: ftc_aroot(:) ! ... in the absorbing root [-] + real(r8) :: btran ! leaf water potential limitation on gs [0-1] @@ -310,6 +331,7 @@ subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) allocate(this%l_aroot_layer(1:nlevsoil_hydr)) allocate(this%th_aroot(1:nlevsoil_hydr)) allocate(this%psi_aroot(1:nlevsoil_hydr)) + allocate(this%ftc_aroot(1:nlevsoil_hydr)) allocate(this%rootuptake(1:nlevsoil_hydr)) return @@ -330,6 +352,7 @@ subroutine DeallocateHydrCohortArrays(this) deallocate(this%l_aroot_layer) deallocate(this%th_aroot) deallocate(this%psi_aroot) + deallocate(this%ftc_aroot) deallocate(this%rootuptake) return diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 70812f7a09..699073e2e2 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -27,6 +27,7 @@ module FatesRestartInterfaceMod use EDCohortDynamicsMod, only : zero_cohort use EDCohortDynamicsMod, only : InitPRTCohort use FatesPlantHydraulicsMod, only : InitHydrCohort + use FatesPlantHydraulicsMod, only : UpdateTreePsiFTCFromTheta use FatesInterfaceMod, only : nlevsclass use PRTGenericMod, only : prt_global @@ -2383,6 +2384,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevsoi_hyd, & ir_hydro_th_aroot_covec,io_idx_co) + + call UpdateTreePsiFTCFromTheta(ccohort%co_hydr,sites(s)%si_hydr) + call this%GetCohortRealVector(ccohort%co_hydr%errh2o_growturn_aroot, & sites(s)%si_hydr%nlevsoi_hyd, & ir_hydro_err_growturn_aroot_covec,io_idx_co) @@ -2550,7 +2554,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_si_sc + 1 end do - sites(s)%term_carbonflux_canopy = rio_termcflux_cano_si(io_idx_si) sites(s)%term_carbonflux_ustory = rio_termcflux_usto_si(io_idx_si) sites(s)%demotion_carbonflux = rio_democflux_si(io_idx_si) From ab6d8833d59917c903da828808c6d3c413ae133b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 4 Sep 2019 11:05:53 -0700 Subject: [PATCH 013/114] More refactor cleaning to fates-hydro. --- biogeophys/FatesPlantHydraulicsMod.F90 | 483 ++++++++++++------------- 1 file changed, 228 insertions(+), 255 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 93219bdd64..193c6c527c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -157,7 +157,6 @@ module FatesPlantHydraulicsMod public :: CopyCohortHydraulics public :: FuseCohortHydraulics public :: updateSizeDepTreeHydProps - public :: updateWaterDepTreeHydProps public :: updateSizeDepTreeHydStates public :: UpdateTreePsiFTCFromTheta public :: initTreeHydStates @@ -579,42 +578,6 @@ end subroutine updateSizeDepTreeHydProps ! ===================================================================================== - subroutine updateWaterDepTreeHydProps(currentSite,ccohort,bc_in) - - - ! DESCRIPTION: Updates absorbing root length (total and its vertical distribution) - ! as well as the consequential change in the size of the 'representative' rhizosphere - ! shell radii, volumes, and compartment volumes of plant tissues - - ! !USES: - use shr_sys_mod , only : shr_sys_abort - - ! ARGUMENTS: - type(ed_site_type) , intent(in) :: currentSite ! Site stuff - type(ed_cohort_type) , intent(inout) :: ccohort ! current cohort pointer - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions - - ! Locals - integer :: nlevsoi_hyd ! Number of total soil layers - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - integer :: ft - - nlevsoi_hyd = currentSite%si_hydr%nlevsoi_hyd - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft - - ! This updates plant compartment volumes, lengths and - ! maximum conductances. Make sure for already - ! initialized vegetation, that SavePreviousCompartment - ! volumes, and UpdateTreeHydrNodes is called prior to this. - - call UpdateWaterDepTreeHydrCond(currentSite,ccohort,nlevsoi_hyd,bc_in) - - - end subroutine updateWaterDepTreeHydProps - - ! ===================================================================================== - subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! ----------------------------------------------------------------------------------- @@ -891,43 +854,50 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr => newCohort%co_hydr ocohort_hydr => oldCohort%co_hydr - - ! BC...PLANT HYDRAULICS - "constants" that change with size. - ! Heights are referenced to soil surface (+ = above; - = below) - ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag - ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag - ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot - ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag - ncohort_hydr%kmax_lower = ocohort_hydr%kmax_lower - ncohort_hydr%kmax_bound = ocohort_hydr%kmax_bound - ncohort_hydr%kmax_treebg_tot = ocohort_hydr%kmax_treebg_tot - ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init - ncohort_hydr%v_ag = ocohort_hydr%v_ag - ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init - ncohort_hydr%v_troot = ocohort_hydr%v_troot - ! quantities indexed by soil layer - ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init - ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer - ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer - - ! BC PLANT HYDRAULICS - state variables - ncohort_hydr%th_ag = ocohort_hydr%th_ag - ncohort_hydr%th_troot = ocohort_hydr%th_troot - ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - ncohort_hydr%psi_ag = ocohort_hydr%psi_ag - ncohort_hydr%psi_troot = ocohort_hydr%psi_troot - ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag - ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot - ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot - - ncohort_hydr%btran = ocohort_hydr%btran - ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag - ncohort_hydr%iterh1 = ocohort_hydr%iterh1 - ncohort_hydr%iterh2 = ocohort_hydr%iterh2 - ncohort_hydr%errh2o = ocohort_hydr%errh2o - ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag - ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag + ! Node heights + ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag + ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag + ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag + ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot + + ! Compartment kmax's + ncohort_hydr%kmax_petiole_to_leaf = ocohort_hydr%kmax_petiole_to_leaf + ncohort_hydr%kmax_stem_lower = ocohort_hydr%kmax_stem_lower + ncohort_hydr%kmax_stem_upper = ocohort_hydr%kmax_stem_upper + ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper + ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower + ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper + ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in + ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out + + ! Compartment volumes + ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init + ncohort_hydr%v_ag = ocohort_hydr%v_ag + ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init + ncohort_hydr%v_troot = ocohort_hydr%v_troot + ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init + ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer + ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer + + ! State Variables + ncohort_hydr%th_ag = ocohort_hydr%th_ag + ncohort_hydr%th_troot = ocohort_hydr%th_troot + ncohort_hydr%th_aroot = ocohort_hydr%th_aroot + ncohort_hydr%psi_ag = ocohort_hydr%psi_ag + ncohort_hydr%psi_troot = ocohort_hydr%psi_troot + ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot + ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag + ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot + ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot + + ! Other + ncohort_hydr%btran = ocohort_hydr%btran + ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag + ncohort_hydr%iterh1 = ocohort_hydr%iterh1 + ncohort_hydr%iterh2 = ocohort_hydr%iterh2 + ncohort_hydr%errh2o = ocohort_hydr%errh2o + ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag + ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag ncohort_hydr%errh2o_growturn_troot = ocohort_hydr%errh2o_growturn_troot ncohort_hydr%errh2o_pheno_troot = ocohort_hydr%errh2o_pheno_troot ncohort_hydr%errh2o_growturn_aroot = ocohort_hydr%errh2o_growturn_aroot @@ -935,10 +905,10 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%sapflow = ocohort_hydr%sapflow - ncohort_hydr%rootuptake = ocohort_hydr%rootuptake + ncohort_hydr%sapflow = ocohort_hydr%sapflow + ncohort_hydr%rootuptake = ocohort_hydr%rootuptake - ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited + ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited end subroutine CopyCohortHydraulics @@ -1005,10 +975,10 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne nextCohort%n*ncohort_hydr%errh2o_growturn_ag(:))/newn ccohort_hydr%errh2o_pheno_ag(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_ag(:) + & nextCohort%n*ncohort_hydr%errh2o_pheno_ag(:))/newn - ccohort_hydr%errh2o_growturn_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot(:) + & - nextCohort%n*ncohort_hydr%errh2o_growturn_troot(:))/newn - ccohort_hydr%errh2o_pheno_troot(:) = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot(:) + & - nextCohort%n*ncohort_hydr%errh2o_pheno_troot(:))/newn + ccohort_hydr%errh2o_growturn_troot = (currentCohort%n*ccohort_hydr%errh2o_growturn_troot + & + nextCohort%n*ncohort_hydr%errh2o_growturn_troot)/newn + ccohort_hydr%errh2o_pheno_troot = (currentCohort%n*ccohort_hydr%errh2o_pheno_troot + & + nextCohort%n*ncohort_hydr%errh2o_pheno_troot)/newn ccohort_hydr%errh2o_growturn_aroot = (currentCohort%n*ccohort_hydr%errh2o_growturn_aroot + & nextCohort%n*ncohort_hydr%errh2o_growturn_aroot)/newn ccohort_hydr%errh2o_pheno_aroot = (currentCohort%n*ccohort_hydr%errh2o_pheno_aroot + & @@ -1473,8 +1443,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! innermost shell radius is less than the assumed ! absorbing root radius rs1 ! 1.e-5_r8 from Rudinger et al 1994 - integer :: nlevsoi_hyd - + integer :: nlevsoi_hyd !----------------------------------------------------------------------- csite_hydr => currentSite%si_hydr @@ -2047,10 +2016,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] ! cohort-specific arrays to hold 1D hydraulics geometric & state variables for entire continuum (leaf,stem,root,soil) - - real(r8) :: ths_node(n_hypool_tot) ! saturated volumetric water in water storage compartments [m3 m-3] - real(r8) :: thr_node(n_hypool_tot) ! residual volumetric water in water storage compartments [m3 m-3] - real(r8) :: the_node(n_hypool_tot) ! error resulting from supersaturation or below-residual th_node [m3 m-3] real(r8) :: th_node(n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] real(r8) :: dth_node(n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] @@ -2075,14 +2040,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: sapflow real(r8) :: rootuptake real(r8) :: totalrootuptake !total root uptake per unit area (kg h2o m-2 time step -1) - real(r8) :: totaldqtopdth_dthdt - real(r8) :: totalqtop_dt !total transpriation per unit area (kg h2o m-2 time step -1) - real(r8) :: total_e !mass balance error (kg h2o m-2 time step -1) - integer :: ncoh_col ! number of cohorts across all non-veg patches within a column real(r8) :: transp_col ! Column mean transpiration rate [mm H2O/m2] ! as defined by the input boundary condition real(r8) :: transp_col_check ! Column mean transpiration rate [mm H2O/m2] as defined ! by the sum of water fluxes through the cohorts + real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating + ! which kmax to use when forecasting uptake layer ordering [MPa] real(r8) :: patch_wgt ! fraction of current patch relative to the whole site ! note that this is almost but not quite cpatch%area/AREA @@ -2140,7 +2103,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%dwat_veg = 0._r8 site_hydr%errh2o_hyd = 0._r8 prev_h2oveg = site_hydr%h2oveg - ncoh_col = 0 ! Calculate the mean site level transpiration flux ! This is usefull to check on mass conservation @@ -2193,7 +2155,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - ncoh_col = ncoh_col + 1 ccohort_hydr%sapflow = 0._r8 ccohort_hydr%rootuptake = 0._r8 @@ -2203,7 +2164,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] if(ccohort%g_sb_laweight>nearzero) then - qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * + qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * & (ccohort%g_sb_laweight/gscan_patch)/ccohort%n else qflx_tran_veg_indiv = 0._r8 @@ -2259,18 +2220,26 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Special case. Maximum conductance depends on the ! potential gradient (same elevation, no geopotential ! required. - if(cohort_hydr%psi_aroot(ilayer) < site_hydr%psisoi_liq_innershell(j)) then - kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) + + call psi_from_th(ccohort%pft, rhiz_p_media, & + site_hydr%h2osoi_liqvol_shell(j,1), & + psi_inner_shell, site_hydr, bc_in) + + ! Note, since their is no elevation difference between + ! the absorbing root and its layer, no need to calc + ! diff in total, just matric is fine [MPa] + if(ccohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = ccohort_hydr%kmax_aroot_radial_in(j) else - kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) + kmax_aroot = ccohort_hydr%kmax_aroot_radial_out(j) end if ! Get matric potential [Mpa] of the absorbing root - call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+2), & - ccohort_hyd%th_aroot(j), psi_aroot, site_hydr, bc_in) + call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+2), & + ccohort_hydr%th_aroot(j), psi_aroot, site_hydr, bc_in) ! Get Fraction of Total Conductivity [-] of the absorbing root - call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+2), & + call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+2), & psi_aroot, ftc_aroot, site_hydr, bc_in) ! Calculate total effective conductance over path [kg s-1 MPa-1] @@ -2281,16 +2250,16 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) froot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) do i = 1,nshell - kmax_up = site_hydr%kmax_outer_shell(j,i)*froot_frac_plant - kmax_lo = site_hydr%kmax_inner_shell(j,i)*froot_frac_plant + kmax_up = site_hydr%kmax_upper_shell(j,i)*froot_frac_plant + kmax_lo = site_hydr%kmax_lower_shell(j,i)*froot_frac_plant - call psi_from_th(currentCohort%pft, porous_media(n_hypool_ag+3), & + call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+3), & site_hydr%h2osoi_liqvol_shell(j,i), psi_shell, site_hydr, bc_in) - call flc_from_psi(currentCohort%pft, porous_media(n_hypool_ag+3), & + call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+3), & psi_shell, ftc_shell, site_hydr, bc_in) - r_shells = r_shells + 1._r8/(kmax_lo*ftc_shell) - if(imax_iter)then write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' write(fates_log(),*) '' - leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & - ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - root_water = (ccohort_hydr%th_troot*ccohort_hydr%v_troot) + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & + cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + root_water = ((cohort_hydr%th_troot*cohort_hydr%v_troot) + & + sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',ccohort%dbh - write(fates_log(),*) 'pft: ',ccohort%pft - write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -2881,21 +2848,21 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, do inode = 1,n_hypool_tot ! Get matric potential [Mpa] - call psi_from_th(currentCohort%pft, porous_media(inode), th_node(inode), & + call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & psi_node(inode), site_hydr, bc_in) ! Get total potential [Mpa] h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) ! Get Fraction of Total Conductivity [-] - call flc_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + call flc_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & ftc_node(inode), site_hydr, bc_in) ! deriv ftc wrt theta - call dpsidth_from_th(currentCohort%pft, porous_media(inode), ccohort_hydr%th_ag(inode), & + call dpsidth_from_th(cohort%pft, porous_media(inode), cohort_hydr%th_ag(inode), & dpsi_dtheta_node(inode), site_hydr, bc_in) - call dflcdpsi_from_psi(currentCohort%pft, porous_media(inode), psi_node(inode), & + call dflcdpsi_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & dftc_dpsi, site_hydr, bc_in) dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) @@ -2912,16 +2879,16 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! ------------------------------------------------------------------------------- jpath = 1 - i_dn = 1 - i_up = 2 - kmax_dn = cohort_hydr%kmax_petiole_to_leaf - kmax_up = cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + i_up = 1 + i_lo = 2 + kmax_up = cohort_hydr%kmax_petiole_to_leaf + kmax_lo = cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -2932,16 +2899,21 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, do jpath=2,n_hypool_ag-1 - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(inode_up-n_hypool_leaf) - kmax_lo = cohort_hydr%kmax_stem_upper(inode_lo-n_hypool_leaf) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + i_up = jpath + i_lo = jpath+1 + ! This compartment is the "upper" node, but uses + ! the "lower" side of its compartment for the calculation. + ! Ultimately, it is more "upper" than its counterpart + kmax_up = cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) + ! This compartment is the "lower" node, but uses + ! the "higher" side of its compartment. + kmax_lo = cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -2952,16 +2924,16 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! Path is between lowest stem and transporting root jpath = n_hypool_ag - i_dn = jpath - i_up = jpath+1 + i_up = jpath + i_lo = jpath+1 kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) kmax_lo = cohort_hydr%kmax_troot_upper - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -2971,16 +2943,16 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! and the absorbing root for this layer jpath = n_hypool_ag+1 - i_dn = jpath - i_up = jpath+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + i_up = jpath + i_lo = jpath+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -2990,24 +2962,24 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! and the first rhizosphere shell nodes jpath = n_hypool_ag+2 - i_dn = jpath - i_up = jpath+1 + i_up = jpath + i_lo = jpath+1 ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - if(h_node(i_dn) < h_node(i_up) ) then + ! potential gradient. + if(h_node(i_up) < h_node(i_lo) ) then kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) else kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) end if + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*root_frac_plant - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -3017,18 +2989,19 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, do jpath = n_hypool_ag+3,n_hpool_tot-1 - i_dn = jpath - i_up = jpath+1 - ishell_dn = i_dn - (n_hypool_ag+2) + i_up = jpath + i_lo = jpath+1 ishell_up = i_up - (n_hypool_ag+2) - kmax_up = site_hydr%kmax_outer_shell(ilayer,ishell_up)*root_frac_plant - kmax_lo = site_hydr%kmax_inner_shell(ilayer,ishell_lo)*root_frac_plant - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta(i_up), dftc_dtheta(i_dn), & - dpsi_dtheta(i_up), dpsi_dtheta(i_dn), & + ishell_lo = i_lo - (n_hypool_ag+2) + + kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*root_frac_plant + kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*root_frac_plant + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & k_eff(jpath), & A_term(jpath), & B_term(jpath)) @@ -3129,9 +3102,9 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, end do ! Save the number of times we refined our sub-step counts (iterh1) - ccohort_hydr%iterh1 = real(iterh1) + cohort_hydr%iterh1 = real(iterh1) ! Save the number of sub-steps we ultimately used - ccohort_hydr%iterh2 = real(nsteps) + cohort_hydr%iterh2 = real(nsteps) ! ----------------------------------------------------------- ! To a final check on water balance error sumed over sub-steps @@ -3141,19 +3114,19 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' - leaf_water = ccohort_hydr%th_ag(1)*ccohort_hydr%v_ag(1)*denh2o - stem_water = sum(ccohort_hydr%th_ag(2:n_hypool_ag) * & - ccohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o + leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o + stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & + cohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = (( cohort_hydr%th_troot*cohort_hydr%v_troot + & + sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',ccohort%dbh - write(fates_log(),*) 'pft: ',ccohort%pft - write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -3161,19 +3134,19 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, ! Adjust final water balance by adding back in the error term ! ------------------------------------------------------------ - if( abs(wb_err*cCohort%n)*AREA_INV>1.0e-7_r8) then - if(debug) then - write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' - endif - !dump the error water to the bin with largest water storage - max_l = maxloc(th_node(:)*v_node(:),dim=1) - th_node(max_l) = th_node(max_l)- & - wb_err/(v_node(max_l)*denh2o) - th_node(max_l) = min (th_node(max_l),& - ths_node(max_l)-small_theta_num) - th_node(max_l) = max(th_node(max_l),& - thr_node(max_l)+small_theta_num) - end if +!! if( abs(wb_err*cohort%n)*AREA_INV>1.0e-7_r8) then +!! if(debug) then +!! write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' +!! endif +!! !dump the error water to the bin with largest water storage +!! max_l = maxloc(th_node(:)*v_node(:),dim=1) +!! th_node(max_l) = th_node(max_l)- & +!! wb_err/(v_node(max_l)*denh2o) +!! th_node(max_l) = min (th_node(max_l),& +!! ths_node(max_l)-small_theta_num) +!! th_node(max_l) = max(th_node(max_l),& +!! thr_node(max_l)+small_theta_num) +!! end if @@ -3187,15 +3160,15 @@ subroutine ImTaylorSolverTermsCond1D(cohort_hydr,site_hydr,ilayer,dt_step,q_top, return - end subroutine ImTaylorSolverTermsCond1D + end subroutine ImTaylorSolve1D ! ================================================================================= - subroutine GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_up,ftc_dn, & - h_up,h_dn, & - dftc_dtheta_up, dftc_dtheta_dn, & - dpsi_dtheta_up, dpsi_dtheta_dn, & + subroutine GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_lo,ftc_up, & + h_lo,h_up, & + dftc_dtheta_lo, dftc_dtheta_up, & + dpsi_dtheta_lo, dpsi_dtheta_up, & k_eff, & A_term, & B_term) @@ -3206,16 +3179,16 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & ! first order expansion). The two terms are generically named A & B. ! Thus the name "KAB". These quantities are specific not to the nodes ! themselves, but to the path between the nodes, defined as positive - ! direction from upstream node to downstream node. + ! direction from "up"per (closer to atm) and "lo"wer (further from atm). ! ----------------------------------------------------------------------------- - real(r8),intent(in) :: kmax_up, kmax_dn ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: ftc_up, ftc_dn ! frac total conductance [-] - real(r8),intent(in) :: h_up, h_dn ! total potential [Mpa] - real(r8),intent(in) :: dftc_dtheta_up, dftc_dtheta_dn ! Derivative + real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] + real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] + real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] + real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative ! of FTC wrt relative water content - real(r8),intent(in) :: dpsi_dtheta_up, dpsi_dtheta_dn ! Derivative of matric potential + real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential ! wrt relative water content real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] @@ -3224,18 +3197,18 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_dn*kmax_dn)+1._r8/(ftc_up*kmax_up)) + k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_lo*kmax_lo)) ! Calculate difference in total potential over the path [MPa] - h_diff = h_up - h_dn + h_diff = h_lo - h_up - ! "A" term, which operates on the down-stream node - A_term = (k_eff**2.0_r8) * h_diff * (kmax_dn**-1.0_r8) * (ftc_dn**-2.0_r8) & - * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + ! "A" term, which operates on the upper node (closer to atm) + A_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + * dftc_dtheta_up - k_eff * dpsi_dtheta_up - ! "B" term, which operates on the up-stream node - B_term = (k_eff**2.0_r8) * h_diff * (kmax_up**-1.0_r8) * (ftc_up**-2.0_r8) & - * dftc_dtheta_up + k_eff * dpsi_dtheta_up + ! "B" term, which operates on the lower node (further from atm) + B_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & + * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo From 7daa45b0d35a475f0827849ed1ed376ec75f43b9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 5 Sep 2019 10:23:37 -0700 Subject: [PATCH 014/114] hydro refactor is now running, tackling issues with Zeng root fractions not summing to unity. --- biogeochem/EDCohortDynamicsMod.F90 | 10 +- biogeophys/FatesPlantHydraulicsMod.F90 | 719 +++++++-------------- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 +- main/FatesConstantsMod.F90 | 6 + main/FatesHistoryInterfaceMod.F90 | 12 +- main/FatesHydraulicsMemMod.F90 | 14 +- main/FatesRestartInterfaceMod.F90 | 48 +- 7 files changed, 270 insertions(+), 543 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 943c5abf37..aaafc09c49 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -46,7 +46,8 @@ module EDCohortDynamicsMod use FatesPlantHydraulicsMod, only : DeallocateHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage use FatesPlantHydraulicsMod, only : UpdateTreeHydrNodes - use FatesPlantHydraulicsMod, only : UpdateTreeHydrLenVolCond + use FatesPlantHydraulicsMod, only : UpdateTreeHydrLenVol + use FatesPlantHydraulicsMod, only : UpdatePlantKmax use FatesPlantHydraulicsMod, only : SavePreviousCompartmentVolumes use FatesPlantHydraulicsMod, only : ConstrainRecruitNumber use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index @@ -289,9 +290,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & call UpdateTreeHydrNodes(new_cohort%co_hydr,new_cohort%pft, & new_cohort%hite,nlevsoi_hyd,bc_in) - ! This calculates volumes, lengths and max conductances - call UpdateTreeHydrLenVolCond(new_cohort,nlevsoi_hyd,bc_in) + ! This calculates volumes and lengths + call UpdateTreeHydrLenVol(new_cohort,nlevsoi_hyd,bc_in) + ! This updates the Kmax's of the plant's compartments + call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr,bc_in) + ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. call SavePreviousCompartmentVolumes(new_cohort%co_hydr) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 193c6c527c..5f454cd43b 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -40,6 +40,10 @@ module FatesPlantHydraulicsMod use FatesConstantsMod, only : cm2_per_m2 use FatesConstantsMod, only : g_per_kg use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : mpa_per_pa + use FatesConstantsMod, only : m_per_mm + use FatesConstantsMod, only : pa_per_mpa + use FatesConstantsMod, only : rsnbl_math_prec use EDParamsMod , only : hydr_kmax_rsurf1 use EDParamsMod , only : hydr_kmax_rsurf2 @@ -167,6 +171,7 @@ module FatesPlantHydraulicsMod public :: SavePreviousRhizVolumes public :: UpdateTreeHydrNodes public :: UpdateTreeHydrLenVol + public :: UpdatePlantKmax public :: ConstrainRecruitNumber !------------------------------------------------------------------------------ @@ -347,7 +352,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !it doesn't matter which absorbing root layer the transporting root water !potential is referenced to. - dz = ccohort_hydr%z_node_troot - bc_in(s)%z_sisl(1) + dz = ccohort_hydr%z_node_troot - bc_in%z_sisl(1) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 @@ -721,7 +726,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & - l_aroot_tot + l_aroot_tot ! Partition the total absorbing root lengths and volumes into the active soil layers @@ -737,6 +742,16 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot end do + if(debug) then + if(abs(1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd)))>rsnbl_math_prec) then + write(fates_log(),*) 'The Zeng 2001 root layering scheme should' + write(fates_log(),*) 'have an integrated root fraction at the lowest soil layer' + write(fates_log(),*) 'crootfr: ',zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd)) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end if !check for bleaf end subroutine UpdateTreeHydrLenVol @@ -895,6 +910,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag ncohort_hydr%iterh1 = ocohort_hydr%iterh1 ncohort_hydr%iterh2 = ocohort_hydr%iterh2 + ncohort_hydr%iterlayer = ocohort_hydr%iterlayer ncohort_hydr%errh2o = ocohort_hydr%errh2o ncohort_hydr%errh2o_growturn_ag = ocohort_hydr%errh2o_growturn_ag ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag @@ -907,6 +923,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%sapflow = ocohort_hydr%sapflow ncohort_hydr%rootuptake = ocohort_hydr%rootuptake + ncohort_hydr%qtop = ocohort_hydr%qtop ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited @@ -941,20 +958,25 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & nextCohort%n*ncohort_hydr%th_aroot(:))/newn ccohort_hydr%supsub_flag = 0._r8 - ccohort_hydr%iterh1 = 0._r8 - ccohort_hydr%iterh2 = 0._r8 + + ! Only save the iteration counters for the worse of the two cohorts + if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then + ccohort_hydr%iterh1 = ncohort_hydr%iterh1 + ccohort_hydr%iterh2 = ncohort_hydr%iterh2 + ccohort_hydr%iterlayer = ncohort_hydr%iterlayer + end if do k=1,n_hypool_ag call psi_from_th(currentCohort%pft, porous_media(k), ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k), site_hydr, bc_in) + ccohort_hydr%psi_ag(k)) call flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%ftc_ag(k), site_hydr, bc_in) + ccohort_hydr%ftc_ag(k)) end do call psi_from_th(currentCohort%pft, troot_p_media, ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot, site_hydr, bc_in) + ccohort_hydr%psi_troot) call flc_from_psi(currentCohort%pft, troot_p_media, ccohort_hydr%psi_troot, & - ccohort_hydr%ftc_troot, site_hydr, bc_in) + ccohort_hydr%ftc_troot) do j=1,site_hydr%nlevsoi_hyd call psi_from_th(currentCohort%pft, aroot_p_media, ccohort_hydr%th_aroot(j), & @@ -968,6 +990,8 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne nextCohort%n*ncohort_hydr%sapflow)/newn ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & nextCohort%n*ncohort_hydr%rootuptake)/newn + ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & + nextCohort%n*ncohort_hydr%qtop)/newn ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & nextCohort%n*ncohort_hydr%errh2o)/newn @@ -1437,13 +1461,14 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) type(ed_cohort_type) , pointer :: cCohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] + ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the ! innermost shell radius is less than the assumed ! absorbing root radius rs1 ! 1.e-5_r8 from Rudinger et al 1994 integer :: nlevsoi_hyd + integer, parameter :: k_inner = 1 ! innermost rhizosphere shell !----------------------------------------------------------------------- csite_hydr => currentSite%si_hydr @@ -1475,13 +1500,23 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) do j = 1,csite_hydr%nlevsoi_hyd + ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) + ! + ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] + ! + ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 + ! + ! [mm s-1] * 1e-3 [m mm-1] + ! * 1 [kg m-1 s-2 Pa-1] + ! * 9.8-1 [s2 m-1] + ! * 1e6 [Pa MPa-1] + ! = [kg s-1 m-1 MPa-1] + hksat_s = bc_in%hksat_sisl(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa ! proceed only if the total absorbing root length (site-level) has changed in this layer if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - k_inner = 1 - ! Set the max conductance on the inner shell first. If the node radius ! on the shell is smaller than the root radius, just set the max conductance ! to something extremely high. @@ -2026,11 +2061,26 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: aroot_frac_plant ! The fraction of the total lenght of absorbing roots contained in one soil layer + ! that are devoted to a single plant + ! hydraulics conductances real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] - - + real(r8) :: psi_aroot ! matric potential in absorbing root [MPa] + real(r8) :: ftc_aroot ! fraction of total conductance in absorbing root [-] + real(r8) :: psi_shell ! matric potential of a given shell [-] + real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] + real(r8) :: kmax_up ! Kmax of upper rhizosphere compartments [kg s-1 Mpa-1] + real(r8) :: kmax_lo ! Kamx of lower rhizosphere compartments [kg s-1 Mpa-1] + real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] + real(r8) :: r_bg ! total estimated resistance in below ground compartments + ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) + real(r8) :: wb_error ! Solve error for a single plant-layer [kg] + real(r8) :: wb_error_site ! Error reflecting difference between site storage before and after + ! integration, with the change in the uptake boundary condition + ! that we send to the HLM. [kg/m2] + ! hydraulics other integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] @@ -2053,7 +2103,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! area, and assumes that the HLM has it's own patch ! that is not tracked by FATES which accounts for all ! non-canopy areas across all patches - + real(r8) :: smp ! temporary for matric potential (MPa) integer :: tmp real(r8) :: tmp1 @@ -2064,6 +2114,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: rootfr ! root fraction at different soil layers real(r8) :: prev_h2oveg ! previous time step plant water storage (kg/m2) logical :: recruitflag ! flag to check if there is newly recruited cohorts + integer :: iter ! number of solver iterations used for each cohort x layer + integer :: nsteps ! number of substeps used for the final iteration on linear solve type(ed_site_hydr_type), pointer :: site_hydr type(ed_cohort_hydr_type), pointer :: ccohort_hydr @@ -2158,6 +2210,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ccohort_hydr%sapflow = 0._r8 ccohort_hydr%rootuptake = 0._r8 + ! Relative transpiration of this cohort from the whole patch ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area @@ -2170,6 +2223,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) qflx_tran_veg_indiv = 0._r8 end if + ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) + ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS ! _____ @@ -2223,7 +2278,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call psi_from_th(ccohort%pft, rhiz_p_media, & site_hydr%h2osoi_liqvol_shell(j,1), & - psi_inner_shell, site_hydr, bc_in) + psi_inner_shell, site_hydr, bc_in(s)) ! Note, since their is no elevation difference between ! the absorbing root and its layer, no need to calc @@ -2236,34 +2291,36 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Get matric potential [Mpa] of the absorbing root call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+2), & - ccohort_hydr%th_aroot(j), psi_aroot, site_hydr, bc_in) + ccohort_hydr%th_aroot(j), psi_aroot, site_hydr, bc_in(s)) ! Get Fraction of Total Conductivity [-] of the absorbing root call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+2), & - psi_aroot, ftc_aroot, site_hydr, bc_in) + psi_aroot, ftc_aroot, site_hydr, bc_in(s)) ! Calculate total effective conductance over path [kg s-1 MPa-1] ! from absorbing root node to 1st rhizosphere shell - r_shells = 1._r8/(kmax_aroot*ftc_aroot) + r_bg = 1._r8/(kmax_aroot*ftc_aroot) - ! Path is between rhizosphere shells - froot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - do i = 1,nshell + ! Path is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + do k = 1,nshell - kmax_up = site_hydr%kmax_upper_shell(j,i)*froot_frac_plant - kmax_lo = site_hydr%kmax_lower_shell(j,i)*froot_frac_plant + kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+3), & - site_hydr%h2osoi_liqvol_shell(j,i), psi_shell, site_hydr, bc_in) + site_hydr%h2osoi_liqvol_shell(j,k), psi_shell, site_hydr, bc_in(s)) call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+3), & - psi_shell, ftc_shell, site_hydr, bc_in) + psi_shell, ftc_shell, site_hydr, bc_in(s)) - r_shells = r_shells + 1._r8/(kmax_up*ftc_shell) - if(iccohort_hydr%iterh1) .and. (iter>1) )then + ccohort_hydr%iterlayer = real(j) + end if + + ! Save the number of times we refined our sub-step counts (iterh1) + ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) + ! Save the number of sub-steps we ultimately used + ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) ! Update water contents in the relevant plant compartments [m3/m3] @@ -2312,27 +2381,36 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Absorbing root ccohort_hydr%th_aroot(j) = ccohort_hydr%th_aroot(j) + dth_node(n_hypool_ag+2) - ! Calculate diagnostics + ! Change in water per plant [kg/plant] dwat_veg_coh = & (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o - + ! Accumulate site level diagnosti of plant water change site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV + + ! Update total site-level stored plant water site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV + + ! Remember the error for the cohort ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_error - !! kg/m2 ground/individual - - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area *AREA_INV + ! Update total error in [kg/m2 ground] + ! (RGK: should this be + wb_error*ccohort%n/ccohort%c_area ??? + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area*AREA_INV ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow ccohort_hydr%rootuptake(j) = ccohort_hydr%rootuptake(j) + rootuptake - ! ACCUMULATE CHANGE IN SOIL WATER CONTENT OF EACH COHORT TO COLUMN-LEVEL + ! Save the change in water mass in the rhizosphere. Note that we did + ! not immediately update the state variables upon completing each + ! plant-layer solve. We accumulate the difference, and apply them + ! after all cohort-layers are complete. This allows each cohort + ! to experience the same water conditions (for good or bad). + dth_layershell_col(j,:) = dth_layershell_col(j,:) + & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & ccohort_hydr%l_aroot_layer(j) * & @@ -2355,7 +2433,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo ! Update water potential of transporting root compartment - k = n_hpool_ag+1 + k = n_hypool_ag+1 call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot, & ccohort_hydr%psi_troot, site_hydr, bc_in(s)) call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot, & @@ -2444,9 +2522,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & site_hydr%recruit_w_uptake(:))*dtime - total_e = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) + wb_error_site = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + total_e + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & site_hydr%h2oveg_growturn_err - & @@ -2498,6 +2576,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! Locals integer :: k ! Compartment (node) index + integer :: j ! Soil layer index integer :: k_ag ! Compartment index for above-ground indexed array integer :: pft ! Plant Functional Type index real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] @@ -2520,11 +2599,17 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! and absorbing root node in each layer [kg s-1 MPa-1] real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each ! soil layer [m2] + real(r8) :: roota ! root profile parameter a zeng2001_crootfr + real(r8) :: rootb ! root profile parameter b zeng2001_crootfr + + real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] - pft = ccohort%pft + pft = ccohort%pft + roota = EDPftvarcon_inst%roota_par(pft) + rootb = EDPftvarcon_inst%rootb_par(pft) ! Get the cross-section of the plant's sapwood area [m2] call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) @@ -2584,6 +2669,18 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! Max conductance over the path on the loewr side of the compartment ccohort_hydr%kmax_stem_lower(k_ag) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) + if(debug) then + ! The following clauses should never be true: + if( (z_lower < z_node) .or. & + (z_node < z_upper) .or. & + (kmax_lower < kmax_node ) .or. & + (kmax_node < kmax_upper )) then + write(fates_log(),*) 'Problem calculating stem Kmax' + write(fates_log(),*) z_lower, z_node, z_upper + write(fates_log(),*) kmax_lower, kmax_node, kmax_upper + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if enddo @@ -2619,7 +2716,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & - 1._r8/kmax_troot_upper + 1._r8/ccohort_hydr%kmax_troot_upper ! Calculate the residual resistance below ground, as a resistor ! in series with the existing above ground @@ -2628,7 +2725,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! The max conductance of each layer is in parallel, therefore ! the kmax terms of each layer, should sum to kmax_bg - do j=1,nlevsoi_hyd + do j=1,csite_hydr%nlevsoi_hyd if(j == 1) then rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) else @@ -2663,9 +2760,9 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! or in-to the root). So we calculate the kmax's for both cases, ! and save them for the final conductance calculation. - do j=1,nlevsoi_hyd + do j=1,csite_hydr%nlevsoi_hyd - ! Surface area of the absorbing roots for this cohort in this layer [m2] + ! Surface area of the absorbing roots for a single plant in this layer [m2] surfarea_aroot_layer = 2._r8 * pi_const *csite_hydr%rs1(j) * ccohort_hydr%l_aroot_layer(j) ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] @@ -2681,7 +2778,8 @@ end subroutine UpdatePlantKmax ! =================================================================================== - subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_top,d_th_node,sapflow,rootuptake,wb_err) + subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_top, & + dth_node,sapflow,rootuptake,wb_err,iter,nsteps) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -2689,18 +2787,22 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. ! ------------------------------------------------------------------------------- - ! !ARGUMENTS + ! Arguments (IN) type(ed_cohort_type),intent(in),target :: cohort - type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr + type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr type(ed_site_hydr_type), intent(in),target :: site_hydr - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions - integer , intent(in) :: ilayer ! soil layer index of interest - real(r8) , intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8) , intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] - real(r8),intent(out) :: d_th_node(n_hypool_tot) ! change in theta over the timestep - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - real(r8),intent(out) :: wb_err ! error, transpiration should match change in storage [kg] + type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions + integer, intent(in) :: ilayer ! soil layer index of interest + real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution + real(r8), intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + ! Arguments (OUT) + real(r8),intent(out) :: dth_node(n_hypool_tot) ! change in theta over the timestep + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: wb_err ! error, transpiration should match change in storage [kg] + integer,intent(out) :: iter ! iteration count for sub-step loops + integer,intent(out) :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows + ! Locals integer :: inode ! node index "i" @@ -2710,18 +2812,22 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t integer :: ishell_lo ! rhizosphere shell index on the lower side of flow path integer :: i_up ! node index on the upper (closer to atm) side of current flow-path integer :: i_lo ! node index on the lower (away from atm) side of current flow-path - integer :: iter ! iteration count for sub-steps + integer :: istep ! sub-step count index logical :: solution_found ! logical set to true if a solution was found within error tolerance real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] - real(r8) :: wb_step_err + real(r8) :: wb_step_err ! water balance error over substep [kg] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + real(r8) :: dt_substep ! timestep length of substeps [s] real(r8) :: leaf_water ! kg of water in the leaf real(r8) :: stem_water ! kg of water in the stem real(r8) :: root_water ! kg of water in the transp and absorbing roots real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] - real(r8) :: th_node(n_hypool_tot) + ! before the solve + real(r8) :: th_node(n_hypool_tot) ! "theta" during the solve (dynamic) [m3 m-3] real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] - real(r8) :: v_node(n_hypool_tot) ! volume of the node [m3] + real(r8) :: v_node(n_hypool_tot) ! volume of the node, ie single plant compartments [m3] real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] @@ -2733,12 +2839,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta - real(r8) :: tris_r(n_hypool_tot) - real(r8) :: rootfrac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: tris_r(n_hypool_tot) ! off (constant coefficients) matrix terms + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change + ! in potential [- MPa-1] ! out of the total absorbing roots from the whole community of plants, - - integer, parameter :: max_iter = 5 + integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps + ! by this much + integer, parameter :: max_iter = 5 ! Maximum number of iterations with which we reduce timestep real(r8), parameter :: max_wb_step_err = 1.e-6_r8 real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] @@ -2757,7 +2866,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] ! site_hydr%l_aroot_layer(ilayer) is units [m/site] - froot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) ! For all nodes leaf through rhizosphere @@ -2773,15 +2882,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t z_node(inode) = cohort_hydr%z_node_troot v_node(inode) = cohort_hydr%v_troot th_node_init(inode) = cohort_hydr%th_troot - elseif (inode==n_hyppol_ag+2) then + elseif (inode==n_hypool_ag+2) then z_node(inode) = bc_in%z_sisl(ilayer) - v_node(inode) = cohort_hydr%v_aroot_layer(:) + v_node(inode) = cohort_hydr%v_aroot_layer(ilayer) th_node_init(inode) = cohort_hydr%th_aroot(ilayer) else ishell = inode-(n_hypool_tot+2) z_node(inode) = bc_in%z_sisl(ilayer) ! The volume of the Rhizosphere for a single plant - v_node(inode) = site_hydr%v_shell(ilayer,ishell)*froot_frac_plant + v_node(inode) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) end if @@ -2865,7 +2974,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t call dflcdpsi_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & dftc_dpsi, site_hydr, bc_in) - dftc_dtheta_node(inode) = dftc_psi * dpsi_dtheta_node(inode) + dftc_dtheta_node(inode) = dftc_dpsi * dpsi_dtheta_node(inode) end do @@ -2926,7 +3035,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t jpath = n_hypool_ag i_up = jpath i_lo = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(n_hpool_ag) + kmax_up = cohort_hydr%kmax_stem_lower(n_hypool_stem) kmax_lo = cohort_hydr%kmax_troot_upper call GetImTaylorKAB(kmax_lo,kmax_up, & @@ -2973,7 +3082,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) end if - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*root_frac_plant + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant call GetImTaylorKAB(kmax_lo,kmax_up, & ftc_node(i_lo),ftc_node(i_up), & @@ -2987,15 +3096,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Path is between rhizosphere shells - do jpath = n_hypool_ag+3,n_hpool_tot-1 + do jpath = n_hypool_ag+3,n_hypool_tot-1 i_up = jpath i_lo = jpath+1 ishell_up = i_up - (n_hypool_ag+2) ishell_lo = i_lo - (n_hypool_ag+2) - kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*root_frac_plant - kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*root_frac_plant + kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant + kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant call GetImTaylorKAB(kmax_lo,kmax_up, & ftc_node(i_lo),ftc_node(i_up), & @@ -3015,7 +3124,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! ------------------------------------------------------------------------------- tris_a(1) = 0._r8 - tris_b(1) = A_term(1) - denh20*vol_node(1)/dt_substep + tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep tris_c(1) = B_term(1) tris_r(1) = q_top - k_eff(1)*(h_node(2)-h_node(1)) @@ -3023,7 +3132,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t do inode = 2,n_hypool_tot-1 jpath = inode tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*v_node(inode)/dt_substep tris_c(inode) = B_term(jpath) tris_r(inode) = -k_eff(jpath)*(h_node(inode+1)-h_node(inode)) + & k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) @@ -3033,7 +3142,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t inode = n_hypool_tot jpath = n_hypool_tot tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = -B_term(jpath-1) - denh2o*vol_node(inode)/dt_substep + tris_b(inode) = -B_term(jpath-1) - denh2o*v_node(inode)/dt_substep tris_c(inode) = 0._r8 tris_r(inode) = k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) @@ -3088,7 +3197,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Root uptake is the integrated flux between the first rhizosphere ! shell and the absorbing root - inode = h_hypool_ag+2 + inode = n_hypool_ag+2 rootuptake = rootuptake + dt_substep * & (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) A_term(inode)*dth_node(inode) + & ! dq at node i @@ -3097,14 +3206,11 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do ! do istep = 1,nsteps (substep loop) - iterh1=iterh1+1 + iter=iter+1 end do - ! Save the number of times we refined our sub-step counts (iterh1) - cohort_hydr%iterh1 = real(iterh1) - ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = real(nsteps) + ! ----------------------------------------------------------- ! To a final check on water balance error sumed over sub-steps @@ -3112,12 +3218,12 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if ( abs(wb_err) > max_wb_err ) then write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' + write(fates_log(),*)'transpiration demand: ', dt_step*q_top,' kg/step/plant' leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & cohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = (( cohort_hydr%th_troot*cohort_hydr%v_troot + & + root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' @@ -3145,7 +3251,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t !! th_node(max_l) = min (th_node(max_l),& !! ths_node(max_l)-small_theta_num) !! th_node(max_l) = max(th_node(max_l),& -!! thr_node(max_l)+small_theta_num) +!! thr_node(max_l)+small_theta_num) !! end if @@ -3170,8 +3276,8 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & dftc_dtheta_lo, dftc_dtheta_up, & dpsi_dtheta_lo, dpsi_dtheta_up, & k_eff, & - A_term, & - B_term) + a_term, & + b_term) ! ----------------------------------------------------------------------------- ! This routine will return the effective conductance "K", as well @@ -3182,18 +3288,17 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & ! direction from "up"per (closer to atm) and "lo"wer (further from atm). ! ----------------------------------------------------------------------------- - real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] - real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] - real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative - ! of FTC wrt relative water content - - real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential - ! wrt relative water content - - real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - real(r8),intent(in) :: a_term ! "A" term for path (See tech note) - real(r8),intent(in) :: b_term ! "B" term for path (See tech note) + real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] + real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] + real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] + real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative + ! of FTC wrt relative water content + real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential + ! wrt relative water content + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(out) :: a_term ! "A" term for path (See tech note) + real(r8),intent(out) :: b_term ! "B" term for path (See tech note) + real(r8) :: h_diff ! Total potential difference [MPa] ! Calculate total effective conductance over path [kg s-1 MPa-1] @@ -3203,11 +3308,11 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & h_diff = h_lo - h_up ! "A" term, which operates on the upper node (closer to atm) - A_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + a_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & * dftc_dtheta_up - k_eff * dpsi_dtheta_up ! "B" term, which operates on the lower node (further from atm) - B_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & + b_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo @@ -3310,393 +3415,8 @@ subroutine RecruitWaterStorage(nsites,sites,bc_out) return end subroutine RecruitWaterStorage - - !--------------------------------------------------------------------------------------! - - subroutine Hydraulics_1DSolve(ccohort, ft, z_node, v_node, ths_node, thr_node, kmax_bound, & - kmax_upper, kmax_lower, kmax_bound_aroot_soil1, kmax_bound_aroot_soil2, & - th_node, flc_min_node, qtop, & - dtime, dth_node_outer, the_node, we_area_outer, qtop_dt, & - dqtopdth_dthdt, sapflow, rootuptake, small_theta_num, & - site_hydr, bc_in) - - ! - ! !DESCRIPTION: - ! - ! - ! !ARGUMENTS - type(ed_cohort_type) , intent(inout), target :: ccohort ! current cohort pointer - integer , intent(in) :: ft ! PFT index - real(r8) , intent(in) :: z_node(:) ! nodal height of water storage compartments [m] - real(r8) , intent(in) :: v_node(:) ! volume of water storage compartments [m3] - real(r8) , intent(in) :: ths_node(:) ! saturated volumetric water in water storage compartments [m3 m-3] - real(r8) , intent(in) :: thr_node(:) ! residual volumetric water in water storage compartments [m3 m-3] - real(r8) , intent(in) :: kmax_bound(:) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] - real(r8) , intent(in) :: kmax_upper(:) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] - real(r8) , intent(in) :: kmax_lower(:) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - real(r8) , intent(in) :: kmax_bound_aroot_soil1 ! maximum radial conductance of absorbing roots [kg s-1 MPa-1] - real(r8) , intent(in) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] - real(r8) , intent(in) :: flc_min_node(:) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics) [-] - real(r8) , intent(in) :: qtop ! evaporative flux from canopy [kgh2o indiv-1 s-1] - real(r8) , intent(in) :: thresh ! threshold for water balance error (warning only) [mm h2o] - real(r8) , intent(in) :: thresh_break ! threshold for water balance error (stop model) [mm h2o] - real(r8) , intent(in) :: dtime ! timestep size [s] - real(r8) , intent(in) :: small_theta_num ! avoids theta values equalling thr or ths [m3 m-3] - - ! Inout Arguments - real(r8) , intent(inout) :: th_node(:) ! volumetric water in water storage compartments [m3 m-3] - - ! Output Arguments - real(r8) , intent(out) :: dth_node_outer(:) ! change in volumetric water in water storage compartments [m3 m-3] - real(r8) , intent(out) :: the_node(:) ! error resulting from supersaturation or below-residual th_node [m3 m-3] - real(r8) , intent(out) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2] - real(r8) , intent(out) :: qtop_dt ! integrated transpired water at the end of each sub-step [kg h2o] - real(r8) , intent(out) :: dqtopdth_dthdt - real(r8) , intent(out) :: sapflow - real(r8) , intent(out) :: rootuptake - - - type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions - - ! - ! !LOCAL VARIABLES: - integer :: k ! 1D plant-soil continuum array - integer :: iterh1, iterh2 ! iteration indices [-] - real(r8) :: w_tot_beg_inner - real(r8) :: w_tot_end_inner - real(r8) :: dw_tot_inner - real(r8) :: w_tot_beg_outer ! Total mass of water, outer loop at beginnign (kg h2o) - real(r8) :: w_tot_end_outer ! Total mass of water, outer loop at end (kg h2o) - real(r8) :: dw_tot_outer - real(r8) :: we_tot_inner - real(r8) :: we_area_inner - real(r8) :: we_vol_inner - real(r8) :: we_local - real(r8) :: we_tot_outer - integer :: dt_fac ! timestep divisor [-] - real(r8) :: dt_new ! new timestep [s] - real(r8) :: th_node_init( n_hypool_tot) ! initial volumetric water in water storage compartments [m3 m-3] - real(r8) :: psi_node( n_hypool_tot) ! water potential in water storage compartments [MPa] - real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] - real(r8) :: flc_node( n_hypool_tot) ! fractional loss of conductivity at water storage nodes [-] - real(r8) :: dflcdpsi_node(n_hypool_tot) ! derivative of fractional loss of conductivity wrt psi [MPa-1] - real(r8) :: k_bound( n_hypool_tot) ! lower boundary hydraulic conductance of compartments [kg s-1 MPa-1] - real(r8) :: q_bound( n_hypool_tot) ! lower boundary flux rate [kg s-1] - real(r8) :: hdiff_bound( n_hypool_tot) ! total water potential difference across lower boundary [MPa] - real(r8) :: dhdiffdpsi0( n_hypool_tot) ! derivative of total water potential difference wrt psi above [-] - real(r8) :: dhdiffdpsi1( n_hypool_tot) ! derivative of total water potential difference wrt psi below [-] - real(r8) :: dkbounddpsi0( n_hypool_tot) ! derivative of lower boundary conductance wrt psi above [kg s-1 MPa-2] - real(r8) :: dkbounddpsi1( n_hypool_tot) ! derivative of lower boundary conductance wrt psi below [kg s-1 MPa-2] - real(r8) :: dqbounddpsi0( n_hypool_tot) ! derivative of lower boundary flux rate wrt psi above [kg s-1 MPa-1] - real(r8) :: dqbounddpsi1( n_hypool_tot) ! derivative of lower boundary flux rate wrt psi below [kg s-1 MPa-1] - real(r8) :: dqbounddth0( n_hypool_tot) ! derivative of lower boundary flux rate wrt theta above [kg s-1 m3 m-3] - real(r8) :: dqbounddth1( n_hypool_tot) ! derivative of lower boundary flux rate wrt theta below [kg s-1 m3 m-3] - real(r8) :: dth_node_inner(n_hypool_tot) ! dtheta from inner do while loop [m3 m-3] - real(r8) :: amx(n_hypool_tot) ! "a" left off diagonal of tridiagonal matrix [kg s-1] - real(r8) :: bmx(n_hypool_tot) ! "b" diagonal of tridiagonal matrix [kg s-1] - real(r8) :: cmx(n_hypool_tot) ! "c" right off diagonal of tridiagonal matrix [kg s-1] - real(r8) :: rmx(n_hypool_tot) ! "r" forcing term of tridiagonal matrix [kg s-1] - real(r8) :: supsub_flag_node(n_hypool_tot) ! super saturation or sub residual flag [0-no,1-yes] - real(r8) :: dflcgsdpsi ! derivative of stomatal vuln curve wrt to leaf water potential [MPa-1] - real(r8) :: dflcgsdth ! derivative of stomatal vuln curve wrt to leaf water content [m-3 m3] - real(r8) :: dqtopdflcgs ! derivative of cohort-level transpiration wrt btran [kgh2o indiv-1 s-1] - real(r8) :: dqtopdth_leaf ! derivative of transpiration rate wrt to leaf water content [kgh2o indiv-1 s-1 m-3 m-3] - real(r8) :: th_prev ! temporary [m3 m-3] - real(r8) :: dth_prev ! temporary [m3 m-3] - real(r8) :: dw_total ! temporary [kg] - real(r8) :: we_k ! error for kth node (temporary) [kg] - real(r8) :: the_k ! theta error for kth node (temporary) [m3 m-3] - real(r8) :: supsub_adj_w ! water ajustment due to super saturation or sub residual flag - real(r8) :: leaf_water ! total water in the leaf (kg/plant) - real(r8) :: stem_water ! "" kg/plant - real(r8) :: root_water ! total water in absorbing and transporting roots (kg/plant) - logical :: catch_nan ! flag for nan returned from Tridiagaonal - integer :: index_nan ! highest k index possessing a nan - integer :: index_stem - integer :: index_aroot - integer :: supsub_flag = 0 - integer :: max_l !location of maximum water storage in the array - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - - ! Constants governing solution convergence - integer,parameter :: maxiter = 5 ! maximum iterations for timestep reduction [-] - integer,parameter :: imult = 3 ! iteration index multiplier [-] - real(r8), parameter :: thresh = 1.e-7_r8 ! threshold for water balance error (warning only) [mm h2o] - real(r8), parameter :: thresh_break = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] - - - !---------------------------------------------------------------------- - - ccohort_hydr => ccohort%co_hydr - dth_node_outer(:) = 0._r8 - we_local = 0._r8 - supsub_flag_node = 0._r8 - index_stem = n_hypool_leaf + n_hypool_stem - index_aroot = n_hypool_leaf + n_hypool_stem + n_hypool_troot + n_hypool_aroot - - ! STORE INITIAL STATES - !! in case timestep needs to be chopped in half to balance water - th_node_init(:) = th_node(:) - - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg_outer = sum(th_node(:)*v_node(:))*denh2o - - ! OUTER DO-WHILE LOOP - !! cuts timestep in half until all sub-timesteps (inner do-while loop) balance the water budget - iterh1 = 0 - do while( iterh1 == 0 .or. ((abs(we_local) > thresh .or. supsub_flag /= 0) .and. iterh1 < maxiter) ) - - dt_fac = max(imult*iterh1,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. - - dt_new = dtime/real(dt_fac,r8) ! This is the sub-stem length in seconds - - ! Restore initial states for a fresh attempt using new sub-timesteps - - if(iterh1 .gt. 0) then - th_node(:) = th_node_init(:) - end if - - ! QUANTITIES OF INTEREST - qtop_dt = 0._r8 ! Water loss through transpiration, integrated up to the substep [kg] - dqtopdth_dthdt = 0._r8 - sapflow = 0._r8 - rootuptake = 0._r8 - - ! INNER DO-WHILE LOOP - !! repeats, for dt_frac times, the removal of 1/dt_fac * transpiration - !! (the top boundary flux condition) - !! stops and returns to outer loop if at any point the water budget - !! doesn't balance, so the timestep can be chopped in half again - - iterh2 = 0 - we_local = 0._r8 - supsub_flag = 0 - do while( iterh2 < dt_fac .and. ((abs(we_local) <= thresh .and. & - supsub_flag == 0) .or. iterh1 == (maxiter-1))) - iterh2 = iterh2 + 1 - - ! SET DERIVED STATE VARIABLES OVER ALL NODES - do k = 1, n_hypool_tot - call psi_from_th(ft, porous_media(k), th_node(k), psi_node(k), site_hydr, bc_in) - call dpsidth_from_th(ft, porous_media(k), th_node(k), dpsidth_node(k), site_hydr, bc_in) - call flc_from_psi(ft, porous_media(k), psi_node(k), flc_node(k), site_hydr, bc_in) - call dflcdpsi_from_psi(ft, porous_media(k), psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) - - if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then - if(flc_node(k) > flc_min_node(k)) then - dflcdpsi_node(k) = 0._r8 - flc_node(k) = flc_min_node(k) - end if - end if - enddo - call dflcgsdpsi_from_psi(ccohort_hydr%psi_ag(1),ft, dflcgsdpsi) - dflcgsdth = dflcgsdpsi * dpsidth_node(1) - dqtopdflcgs = 0.1411985_r8 - - !BOC... estimated by trial-and-error: this term multiplied by the maximum value of dflcgsdth gives 150. - !NEEDED: an estimate for dqtopdflcgs that accounts for variable potential evapotranspiration (efpot). - - ! SET THE DQTOPDTH_LEAF TERM - if(do_dqtopdth_leaf) then - dqtopdth_leaf = dqtopdflcgs * dflcgsdth - else - dqtopdth_leaf = 0._r8 - end if - - ! SET BOUNDARY PRESSURE DIFFERENCES & CONDUCTANCES - !! compute water potential differences + conductances and their derivatives wrt water potential - call boundary_hdiff_and_k( n_hypool_tot-nshell, & ! where the boundary occurs between root and soil (absorbing root node) - z_node, & ! elevation of all compartments [m] - psi_node, & ! water potential in compartment [Mpa] - flc_node, & ! frac loss conductivity [kg s-1 Mpa-1] - dflcdpsi_node, & ! change in FLC per change in water potential [kg s-1 Mpa-2] - kmax_bound, & ! max conductance at lower boundary of node [kg s-1 Mpa-1] - kmax_upper, & - kmax_lower, & - hdiff_bound, & ! out: difference in potential across nodes [Mpa] - k_bound, & - dhdiffdpsi0, & - dhdiffdpsi1, & - dkbounddpsi0, & - dkbounddpsi1, & - kmax_bound_aroot_soil1, & - kmax_bound_aroot_soil2) - - ! SET BOUNDARY FLUX TERMS - !! compute flux terms and their derivatives wrt water content - q_bound(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) - dqbounddpsi0(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * dhdiffdpsi0(1:n_hypool_tot-1) - & - dkbounddpsi0(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) - dqbounddpsi1(1:n_hypool_tot-1) = -1._r8 * k_bound(1:n_hypool_tot-1) * dhdiffdpsi1(1:n_hypool_tot-1) - & - dkbounddpsi1(1:n_hypool_tot-1) * hdiff_bound(1:n_hypool_tot-1) - dqbounddth0(1:n_hypool_tot-1) = dqbounddpsi0(1:n_hypool_tot-1) * dpsidth_node(1:n_hypool_tot-1) - dqbounddth1(1:n_hypool_tot-1) = dqbounddpsi1(1:n_hypool_tot-1) * dpsidth_node(2:n_hypool_tot) - - !! zero-flux outer soil shell boundary condition - q_bound(n_hypool_tot) = 0._r8 - dqbounddpsi0(n_hypool_tot) = 0._r8 - dqbounddpsi1(n_hypool_tot) = 0._r8 - dqbounddth0(n_hypool_tot) = 0._r8 - dqbounddth1(n_hypool_tot) = 0._r8 - - ! STORE BEGINNING WATER BALANCE - w_tot_beg_inner = sum(th_node(:)*v_node(:))*denh2o - - ! SET UP TRIDIAGONAL MATRIX - !! upper (leaf) layer - k = 1 - rmx(k) = qtop - q_bound(k) - amx(k) = 0._r8 - bmx(k) = dqbounddth0(k) - dqtopdth_leaf - v_node(k)*denh2o/dt_new - cmx(k) = dqbounddth1(k) - - !! intermediate nodes (plant and soil) - do k=2,(n_hypool_tot-1) - rmx(k) = q_bound(k-1) - q_bound(k) - amx(k) = -1._r8 * dqbounddth0(k-1) - bmx(k) = dqbounddth0(k) - dqbounddth1(k-1) - v_node(k)*denh2o/dt_new - cmx(k) = dqbounddth1(k) - enddo - - !! outermost rhizosphere shell - k = n_hypool_tot - rmx(k) = q_bound(k-1) - amx(k) = -1._r8 * dqbounddth0(k-1) - bmx(k) = -dqbounddth1(k-1) - v_node(k)*denh2o/dt_new - cmx(k) = 0._r8 - - ! SOLVE TRIDIAGONAL MATRIX - call Hydraulics_Tridiagonal(amx, bmx, cmx, rmx, dth_node_inner) - - ! CATCH NAN VALUES - catch_nan = .false. - index_nan = 999 - do k = 1, n_hypool_tot - if(isnan(dth_node_inner(k))) then - catch_nan = .true. - index_nan = k - end if - end do - if(catch_nan) then - write(fates_log(),*)'EDPlantHydraulics returns nan at k = ', index_nan - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! CATCH SUPERSATURATED OR SUB-RESIDUAL WATER CONTENTS - ccohort_hydr%supsub_flag = 0._r8 - supsub_flag = 0 - do k=1,n_hypool_tot - th_prev = th_node(k) - dth_prev = dth_node_inner(k) - if( (th_node(k)+dth_node_inner(k)) > (ths_node(k)-small_theta_num)) then - supsub_flag = k - supsub_flag_node(k) = 1._r8 - ccohort_hydr%supsub_flag = real(k) - th_node(k) = ths_node(k)-small_theta_num - else if((th_node(k)+dth_node_inner(k)) < (thr_node(k)+small_theta_num)) then - supsub_flag = -k - ccohort_hydr%supsub_flag = -real(k) - supsub_flag_node(k) = -1._r8 - th_node(k) = thr_node(k)+small_theta_num - else - th_node(k) = th_node(k)+dth_node_inner(k) - end if - dth_node_inner(k) = th_node(k) - th_prev - the_node(k) = dth_node_inner(k) - dth_prev - enddo - - ! QUANTITIES OF INTEREST - qtop_dt = qtop_dt + & - qtop*dt_new - dqtopdth_dthdt = dqtopdth_dthdt + & - dqtopdth_leaf*dth_node_inner(1)*dt_new - sapflow = sapflow + & - (q_bound(index_stem) + & - dqbounddth0(index_stem)*dth_node_inner(index_stem) + & - dqbounddth1(index_stem)*dth_node_inner(index_stem+1))*dt_new - rootuptake = rootuptake + & - (q_bound(index_aroot) + & - dqbounddth0(index_aroot)*dth_node_inner(index_aroot) + & - dqbounddth1(index_aroot)*dth_node_inner(index_aroot+1))*dt_new - - ! UPDATE ERROR TERM - w_tot_end_inner = sum(th_node(:)*v_node(:))*denh2o - dw_tot_inner = w_tot_end_inner - w_tot_beg_inner - - we_tot_inner = dw_tot_inner/dt_new + (qtop + dqtopdth_leaf*dth_node_inner(1)) - - we_area_inner = we_tot_inner/(cCohort%c_area / cCohort%n) - we_vol_inner = we_tot_inner/sum(v_node(:)) - - ! we_vol_inner - ! different water balance metrics can be chosen here (with an appropriate corresponding thresh) - we_local = we_tot_inner*cCohort%n*AREA_INV - - end do ! loop over sub-timesteps - - iterh1 = iterh1 + 1 - - end do ! loop to get a timestep divisor that balances water - - ccohort_hydr%iterh1 = real(iterh1) - ccohort_hydr%iterh2 = real(iterh2) - - ! WATER BALANCE ERROR-HANDLING - if ( (abs(we_local) > thresh) .and. debug) then - write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds threshold of ',& - thresh - else if (abs(we_local) > thresh_break) then - write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', thresh_break - write(fates_log(),*)'transpiration demand: ', dtime*qtop,' kg/step/plant' - - leaf_water = sum(ccohort_hydr%th_ag(1:n_hypool_leaf)* & - ccohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(ccohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - - root_water = ( ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:))) * denh2o - - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',ccohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',ccohort%dbh - write(fates_log(),*) 'pft: ',ccohort%pft - write(fates_log(),*) 'tree lai: ',ccohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! TOTAL NET WATER BALANCE AND ERROR ADJUST HACK - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - if(abs(we_tot_outer*cCohort%n)*AREA_INV>1.0e-7_r8) then - if(debug) then - write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' - endif - !dump the error water to the bin with largest water storage - max_l = maxloc(th_node(:)*v_node(:),dim=1) - th_node(max_l) = th_node(max_l)- & - we_tot_outer/(v_node(max_l)*denh2o) - th_node(max_l) = min (th_node(max_l),& - ths_node(max_l)-small_theta_num) - th_node(max_l) = max(th_node(max_l),& - thr_node(max_l)+small_theta_num) - w_tot_end_outer = sum(th_node(:)*v_node(:))*denh2o ! kg - dw_tot_outer = w_tot_end_outer - w_tot_beg_outer ! kg/timestep - we_tot_outer = dw_tot_outer + (qtop_dt + dqtopdth_dthdt) ! kg/timestep - we_area_outer = we_tot_outer/(cCohort%c_area / cCohort%n) ! kg/m2 ground/individual - end if - dth_node_outer(:) = th_node(:) - th_node_init(:) - - end subroutine Hydraulics_1DSolve - !-------------------------------------------------------------------------------! + subroutine Hydraulics_Tridiagonal(a, b, c, r, u) ! ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 @@ -3805,7 +3525,7 @@ subroutine boundary_hdiff_and_k(k_arootsoil, z_node, psi_node, flc_node, dflcdps !---------------------------------------------------------------------- do k = 1, (size(z_node)-1) - hdiff_bound(k) = 1.e-6_r8*denh2o*grav_earth*(z_node(k) - z_node(k+1)) + & + hdiff_bound(k) = mpa_per_pa*denh2o*grav_earth*(z_node(k) - z_node(k+1)) + & (psi_node(k) - psi_node(k+1)) if(do_kbound_upstream) then @@ -3921,8 +3641,8 @@ subroutine flc_from_psi(ft, pm, psi_node, flc_node, site_hydr, bc_in ) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: psi_node ! water potential [MPa] real(r8) , intent(out) :: flc_node ! fractional loss of conductivity [-] - type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure - type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions + type(ed_site_hydr_type),optional, intent(in),target :: site_hydr ! ED site_hydr structure + type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions ! ! !LOCAL VARIABLES: @@ -3975,7 +3695,7 @@ subroutine dflcdpsi_from_psi(ft, pm, psi_node, dflcdpsi_node, site_hydr, bc_in ) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: psi_node ! water potential [MPa] real(r8) , intent(out) :: dflcdpsi_node ! fractional loss of conductivity [-] -type(ed_site_hydr_type),optional, intent(inout),target :: site_hydr ! ED site_hydr structure +type(ed_site_hydr_type),optional, intent(in),target :: site_hydr ! ED site_hydr structure type(bc_in_type),optional, intent(in) :: bc_in ! FATES boundary conditions ! @@ -4026,7 +3746,7 @@ subroutine th_from_psi(ft, pm, psi_node, th_node, site_hydr, bc_in) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: psi_node ! water potential [MPa] real(r8) , intent(out) :: th_node ! water content [m3 m-3] -type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure +type(ed_site_hydr_type), intent(in),target :: site_hydr ! ED site_hydr structure type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions ! @@ -4126,8 +3846,7 @@ subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) integer :: nitr ! number of iterations !---------------------------------------------------------------------- if(psi_node > 0.0_r8) then -write(fates_log(),*)'Error: psi_note become positive,& - psi_node=',psi_node +write(fates_log(),*)'Error: psi_note become positive, psi_node=',psi_node call endrun(msg=errMsg(sourcefile, __LINE__)) endif call psi_from_th(ft, pm, lower, y_lo) @@ -4170,7 +3889,7 @@ subroutine psi_from_th(ft, pm, th_node, psi_node, site_hydr, bc_in) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: th_node ! water content [m3 m-3] real(r8) , intent(out) :: psi_node ! water potential [MPa] -type(ed_site_hydr_type), optional, intent(inout),target :: site_hydr ! ED site_hydr structure +type(ed_site_hydr_type), optional, intent(in),target :: site_hydr ! ED site_hydr structure type(bc_in_type), optional, intent(in) :: bc_in ! FATES boundary conditions ! ! !LOCAL VARIABLES: @@ -4225,7 +3944,7 @@ subroutine dpsidth_from_th(ft, pm, th_node, y, site_hydr, bc_in) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: th_node ! water content [m3 m-3] real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -type(ed_site_hydr_type), optional,intent(inout) :: site_hydr +type(ed_site_hydr_type), optional,intent(in) :: site_hydr type(bc_in_type), optional,intent(in) :: bc_in ! ! !LOCAL VARIABLES: diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 4e003474a3..59531574de 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -396,8 +396,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if (hlm_use_planthydro.eq.itrue ) then - bbb = max( cf/rsmax0, bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran(1) ) - btran_eff = currentCohort%co_hydr%btran(1) + bbb = max( cf/rsmax0, bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran ! dinc_ed is the total vegetation area index of each "leaf" layer ! we convert to the leaf only portion of the increment diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 90a11f1b14..8ab0c40a77 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -88,6 +88,12 @@ module FatesConstantsMod ! Conversion factor: umols per kilomole real(fates_r8), parameter, public :: umol_per_kmol = 1.0E9_fates_r8 + ! Conversion factor: meters per milimeter + real(fates_r8), parameter, public :: m_per_mm = 1.0E-6_fates_r8 + + ! Conversion factor: milimeters per meter + real(fates_r8), parameter, public :: mm_per_m = 1.0E6_fates_r8 + ! Conversion factor: m2 per ha real(fates_r8), parameter, public :: m2_per_ha = 1.0e4_fates_r8 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8b191c1fce..7cdf74fdd9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3275,7 +3275,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & - hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & + hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & hio_tflc_scpf => this%hvars(ih_tflc_scpf)%r82d, & hio_sflc_scpf => this%hvars(ih_sflc_scpf)%r82d, & hio_lflc_scpf => this%hvars(ih_lflc_scpf)%r82d, & @@ -3351,7 +3351,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%errh2o * number_fraction_rate ! [kg/indiv/s] hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & - (ccohort_hydr%qtop_dt + ccohort_hydr%dqtopdth_dthdt) * number_fraction_rate ! [kg/indiv/s] + (ccohort_hydr%qtop) * number_fraction_rate ! [kg/indiv/s] hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & sum(ccohort_hydr%rootuptake) * number_fraction_rate ! [kg/indiv/s] @@ -3395,16 +3395,16 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] hio_aflc_scpf(io_si,iscpf) = hio_aflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_aroot(1) * number_fraction + ccohort_hydr%ftc_aroot(1) * number_fraction hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_troot * number_fraction + ccohort_hydr%ftc_troot * number_fraction hio_sflc_scpf(io_si,iscpf) = hio_sflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_ag(2) * number_fraction + ccohort_hydr%ftc_ag(2) * number_fraction hio_lflc_scpf(io_si,iscpf) = hio_lflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_ag(1) * number_fraction + ccohort_hydr%ftc_ag(1) * number_fraction hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & ccohort_hydr%btran * number_fraction ! [-] diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9bfe95c2e5..1e8ab8a642 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -254,8 +254,11 @@ module FatesHydraulicsMemMod real(r8) :: supsub_flag ! k index of last node to encounter supersaturation or ! sub-residual water content (+ supersaturation; - subsaturation) - real(r8) :: iterh1 ! number of iterations required to achieve tolerable water balance error - real(r8) :: iterh2 ! number of inner iterations + real(r8) :: iterh1 ! max number of iterations required to achieve tolerable + ! water balance error (if 1D, associated with iterlayer) + real(r8) :: iterh2 ! number of inner iterations (if 1D, associated with iterlayer) + real(r8) :: iterlayer ! layer index associated with the highest iterations + real(r8) :: errh2o ! total water balance error per unit crown area [kgh2o/m2] real(r8) :: errh2o_growturn_ag(n_hypool_ag) ! error water pool for increase (growth) or ! contraction (turnover) of tissue volumes. @@ -278,10 +281,9 @@ module FatesHydraulicsMemMod ! Useful diagnostics ! ---------------------------------------------------------------------------------- - real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] - real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/indiv/timestep] - ! BC PLANT HYDRAULICS - flags - + real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] + real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/indiv/timestep] + real(r8) :: qtop ! mean transpiration flux rate [kg/indiv/timestep] ! Other ! ---------------------------------------------------------------------------------- diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index bb70328877..3f394ecbb8 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -176,12 +176,12 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec - integer :: ir_hydro_th_troot_covec + integer :: ir_hydro_th_troot integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si - integer :: ir_hydro_err_growturn_aroot_covec + integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec - integer :: ir_hydro_err_growturn_troot_covec + integer :: ir_hydro_err_growturn_troot integer :: ir_hydro_recruit_si integer :: ir_hydro_dead_si integer :: ir_hydro_growturn_err_si @@ -897,7 +897,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_troot', vtype=cohort_r8, & long_name_base='water in transporting roots', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) call this%RegisterCohortVector(symbol_base='fates_hydro_th_aroot', vtype=cohort_r8, & long_name_base='water in absorbing roots', & @@ -907,7 +907,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_err_aroot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_aroot) call this%RegisterCohortVector(symbol_base='fates_hydro_err_ag', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & @@ -917,7 +917,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_err_troot', vtype=cohort_r8, & long_name_base='error in plant-hydro balance above ground', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_troot) ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & @@ -1638,23 +1638,22 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) - call this%SetCohortRealVector(ccohort%co_hydr%th_troot,n_hypool_troot, & - ir_hydro_th_troot_covec,io_idx_co) call this%SetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevsoi_hyd, & ir_hydro_th_aroot_covec,io_idx_co) - ! Load the error terms - call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_aroot, & - sites(s)%si_hydr%nlevsoi_hyd, & - ir_hydro_err_growturn_aroot_covec,io_idx_co) - - call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_troot, & - n_hypool_troot, & - ir_hydro_err_growturn_troot_covec,io_idx_co) + this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) = ccohort%co_hydr%th_troot + ! Load the error terms call this%setCohortRealVector(ccohort%co_hydr%errh2o_growturn_ag, & n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) + + this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) = & + ccohort%co_hydr%errh2o_growturn_aroot + + this%rvars(ir_hydro_err_growturn_troot)%r81d(io_idx_co) = & + ccohort%co_hydr%errh2o_growturn_troot + end if @@ -2388,21 +2387,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) - call this%GetCohortRealVector(ccohort%co_hydr%th_troot,n_hypool_troot, & - ir_hydro_th_troot_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevsoi_hyd, & ir_hydro_th_aroot_covec,io_idx_co) - - call UpdateTreePsiFTCFromTheta(ccohort%co_hydr,sites(s)%si_hydr) + ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) + + call UpdateTreePsiFTCFromTheta(ccohort,sites(s)%si_hydr) - call this%GetCohortRealVector(ccohort%co_hydr%errh2o_growturn_aroot, & - sites(s)%si_hydr%nlevsoi_hyd, & - ir_hydro_err_growturn_aroot_covec,io_idx_co) - call this%GetCohortRealVector(ccohort%co_hydr%errh2o_growturn_troot, & - n_hypool_troot, & - ir_hydro_err_growturn_troot_covec,io_idx_co) + ccohort%co_hydr%errh2o_growturn_aroot = & + this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) + ccohort%co_hydr%errh2o_growturn_troot = & + this%rvars(ir_hydro_err_growturn_troot)%r81d(io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%errh2o_growturn_ag, & n_hypool_ag, & From a49818c912cef8145e3d3457d007d8ce99ac5b81 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 5 Sep 2019 16:38:16 -0700 Subject: [PATCH 015/114] hydrualics - minor fixes to refactor. --- biogeophys/FatesPlantHydraulicsMod.F90 | 250 ++++++++++++++----------- 1 file changed, 145 insertions(+), 105 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5f454cd43b..bdcb3f1252 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -342,7 +342,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) call th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & ccohort_hydr%th_aroot(j), csite%si_hydr, bc_in ) call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%ftc_ag(j), csite%si_hydr, bc_in) + ccohort_hydr%ftc_aroot(j), csite%si_hydr, bc_in) end do @@ -733,20 +733,22 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! ------------------------------------------------------------------------------ do j=1,nlevsoi_hyd if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), bc_in%zi_sisl(nlevsoi_hyd)) end if ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot end do if(debug) then - if(abs(1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd)))>rsnbl_math_prec) then + if(abs(1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd), & + bc_in%zi_sisl(nlevsoi_hyd)))>rsnbl_math_prec) then write(fates_log(),*) 'The Zeng 2001 root layering scheme should' write(fates_log(),*) 'have an integrated root fraction at the lowest soil layer' - write(fates_log(),*) 'crootfr: ',zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd)) + write(fates_log(),*) 'crootfr: ',zeng2001_crootfr(roota, rootb, & + bc_in%zi_sisl(nlevsoi_hyd), bc_in%zi_sisl(nlevsoi_hyd)) call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if @@ -1304,10 +1306,13 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) else do j=1,csite_hydr%nlevsoi_hyd if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) + rootfr = zeng2001_crootfr(roota, rootb, & + bc_in(s)%zi_sisl(j), bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) else - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j), & + bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1), & + bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) end if csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & recruitw*rootfr @@ -1371,10 +1376,13 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) do j=1,csite_hydr%nlevsoi_hyd if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) end if cohort_recruit_water_layer(j) = recruitw*rootfr end do @@ -1491,7 +1499,6 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) do j = 1,nlevsoi_hyd ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, bc_in%dz_sisl(j), & csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) end if !has l_aroot_layer changed? @@ -2605,6 +2612,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] + real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference + ! in the top of stem and petiole pft = ccohort%pft @@ -2638,7 +2647,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) - z_upper = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_upper_ag(k_ag) + z_upper = max( min_pet_stem_dz,ccohort_hydr%z_node_ag(n_hypool_leaf) - & + ccohort_hydr%z_upper_ag(k_ag)) ! Then we calculate the maximum conductance from each the lower, node and upper @@ -2649,6 +2659,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! series. ! max conductance from upper edge to mean petiole height + ! If there is no height difference between the upper compartment edge and + ! the petiole, at least give it some nominal amount to void FPE's kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & xylemtaper(taper_exponent, z_upper) * & a_sapwood / z_upper @@ -2664,24 +2676,22 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) a_sapwood / z_lower ! Max conductance over the path of the upper side of the compartment - ccohort_hydr%kmax_stem_upper(k_ag) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + ccohort_hydr%kmax_stem_upper(k) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) ! Max conductance over the path on the loewr side of the compartment - ccohort_hydr%kmax_stem_lower(k_ag) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) - + ccohort_hydr%kmax_stem_lower(k) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) + if(debug) then - ! The following clauses should never be true: - if( (z_lower < z_node) .or. & - (z_node < z_upper) .or. & - (kmax_lower < kmax_node ) .or. & - (kmax_node < kmax_upper )) then - write(fates_log(),*) 'Problem calculating stem Kmax' - write(fates_log(),*) z_lower, z_node, z_upper - write(fates_log(),*) kmax_lower, kmax_node, kmax_upper - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! The following clauses should never be true: + if( (z_lower < z_node) .or. & + (z_node < z_upper) ) then + write(fates_log(),*) 'Problem calculating stem Kmax' + write(fates_log(),*) z_lower, z_node, z_upper + write(fates_log(),*) kmax_lower*z_lower, kmax_node*z_node, kmax_upper*z_upper + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if - + enddo ! Maximum conductance of the upper compartment in the transporting root @@ -2727,10 +2737,13 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! the kmax terms of each layer, should sum to kmax_bg do j=1,csite_hydr%nlevsoi_hyd if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1)) + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), & + bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) end if kmax_layer = rootfr*kmax_bg @@ -2887,7 +2900,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t v_node(inode) = cohort_hydr%v_aroot_layer(ilayer) th_node_init(inode) = cohort_hydr%th_aroot(ilayer) else - ishell = inode-(n_hypool_tot+2) + ishell = inode-(n_hypool_ag+2) z_node(inode) = bc_in%z_sisl(ilayer) ! The volume of the Rhizosphere for a single plant v_node(inode) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant @@ -2968,7 +2981,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ftc_node(inode), site_hydr, bc_in) ! deriv ftc wrt theta - call dpsidth_from_th(cohort%pft, porous_media(inode), cohort_hydr%th_ag(inode), & + call dpsidth_from_th(cohort%pft, porous_media(inode), th_node(inode), & dpsi_dtheta_node(inode), site_hydr, bc_in) call dflcdpsi_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & @@ -3444,6 +3457,7 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) real(r8) :: err ! solution error, in units of [m3/m3] real(r8) :: rel_err ! relative error, normalized by delta theta real(r8), parameter :: allowable_rel_err = 0.001_r8 +! real(r8), parameter :: allowable_err = 1.e-6_r8 !---------------------------------------------------------------------- bet = b(1) @@ -3467,22 +3481,23 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) do k=1,n_hypool_tot if(k==1)then - err = abs(r(k) - b(k)*u(k)+c(k)*u(k+1)) + err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) elseif(k allowable_rel_err)then + if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then write(fates_log(),*) 'Tri-diagonal solve produced solution with' write(fates_log(),*) 'non-negligable error.' write(fates_log(),*) 'Compartment: ',k write(fates_log(),*) 'Error in forward solution: ',err write(fates_log(),*) 'Estimated delta theta: ',u(k) write(fates_log(),*) 'Rel Error: ',rel_err + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do @@ -5096,86 +5111,111 @@ end subroutine bisect_rootfr ! ===================================================================================== -function zeng2001_crootfr(a, b, z) result(crootfr) +function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: + real(r8) , intent(in) :: a,b ! pft parameters + real(r8) , intent(in) :: z ! soil depth (m) + real(r8) , intent(in), optional :: z_max ! max soil depth (m) + ! + real(r8) :: crootfr_max - ! !ARGUMENTS: -real(r8) , intent(in) :: a,b ! pft parameters -real(r8) , intent(in) :: z ! soil depth (m) -! -! !RESULT -real(r8) :: crootfr ! cumulative root fraction -! -!------------------------------------------------------------------------ -crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + ! !RESULT + real(r8) :: crootfr ! cumulative root fraction + ! + !------------------------------------------------------------------------ + crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) -return + ! If a maximum rooting depth is provided, then + ! we force everything to sum to unity. We do this by + ! simply dividing through by the maximum possible + ! root fraction. + + if(present(z_max))then + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max + end if + + if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max + end if + end if + end if + + + return + end function zeng2001_crootfr ! ===================================================================================== subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: - - ! - ! !ARGUMENTS: -real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots -! for the whole site, this layer (m) -real(r8) , intent(in) :: rs1 ! Fine root radius (m) -real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) -real(r8) , intent(in) :: dz ! Width of current soil layer (m) -real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) -real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint -real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) -! for this layer -! -! !LOCAL VARIABLES: -integer :: k ! rhizosphere shell indicies -!----------------------------------------------------------------------- + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: -! update outer radii of column-level rhizosphere shells (same across patches and cohorts) -r_out_shell(nshell) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 -if(nshell > 1) then -do k = 1,nshell-1 -r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 -enddo -end if + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots + ! for the whole site, this layer (m) + real(r8) , intent(in) :: rs1 ! Fine root radius (m) + real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) + real(r8) , intent(in) :: dz ! Width of current soil layer (m) + real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) + real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint + real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) + ! for this layer + ! + ! !LOCAL VARIABLES: + integer :: k ! rhizosphere shell indicies + !----------------------------------------------------------------------- -! set nodal (midpoint) radii of these shells -! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level -r_node_shell(k) = 0.5_r8*(rs1 + r_out_shell(k)) -!r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + r_out_shell(nshell) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshell > 1) then + do k = 1,nshell-1 + r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 + enddo + end if -do k = 2,nshell -r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) -enddo + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) -! update volumes -if(voltype==bcvol)then -do k = 1,nshell -if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level -v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) + do k = 2,nshell + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo -else -v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) -end if -enddo -elseif(voltype==rkvol)then -do k = 1,nshell -if(k == 1) then -v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) -else -v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) -end if -enddo -end if + ! update volumes + if(voltype==bcvol)then + do k = 1,nshell + if(k == 1) then + ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level + v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) + + else + v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + elseif(voltype==rkvol)then + do k = 1,nshell + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + end if end subroutine shellGeom From 9108ffc564e31ff9b8f1c07b21f5103bea55caf8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Sep 2019 10:57:54 -0700 Subject: [PATCH 016/114] More refactors to hydro, mostly diagnostics during debug --- biogeophys/FatesPlantHydraulicsMod.F90 | 384 ++++++++++++++----------- main/EDMainMod.F90 | 4 - 2 files changed, 219 insertions(+), 169 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index bdcb3f1252..92f5459fbe 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -112,6 +112,11 @@ module FatesPlantHydraulicsMod integer, parameter :: campbell = 2 integer :: iswc = campbell + ! Currently testing two different ways to represent rhizosphere shell + ! volumes. The old way used a "representative" shell volume, the + ! new way is an absolute volume, in total cubic meters over the + ! whole hectare. + integer, parameter :: bcvol = 1 integer, parameter :: rkvol = 2 integer, parameter :: voltype = rkvol @@ -122,20 +127,29 @@ module FatesPlantHydraulicsMod integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran ! 1 => use BC hydraulics; ! 2 => use CX hydraulics - logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf + + + ! The following options are temporarily unavailable (RGK 09-06-19) + ! ---------------------------------------------------------------------------------- + + ! logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf ! term be applied to the plant ! hydraulics numerical solution? - logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling + !logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling ! (i.e., non-instantaneous) be considered ! within plant hydraulics? - logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the + !logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the ! boundary between nodes be taken to be a ! function of the upstream loss of ! conductivity (flc)? + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent - ! hydraulic properties and states be - ! updated every day when trees grow or - ! when recruitment happens? + ! hydraulic properties and states be + ! updated every day when trees grow or + ! when recruitment happens? + + + logical,parameter :: debug = .true. !flag to report warning in hydro @@ -146,7 +160,6 @@ module FatesPlantHydraulicsMod ! We use this parameter as the value for which we set un-initialized values real(r8), parameter :: un_initialized = -9.9e32_r8 - ! ! !PUBLIC MEMBER FUNCTIONS: public :: AccumulateMortalityWaterStorage @@ -420,7 +433,6 @@ subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) end do ! Update the Psi and FTC for the transporting root compartment - k = n_hypool_ag+1 call psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot, ccohort_hydr%psi_troot) call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) @@ -509,8 +521,11 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) ccohort_hydr%z_node_troot = -z_cumul_rf - - + !write(fates_log(),*)'h: ',plant_height + !write(fates_log(),*)'z upper: ', ccohort_hydr%z_upper_ag + !write(fates_log(),*)'z nodes: ', ccohort_hydr%z_node_ag + !write(fates_log(),*)'z lower: ', ccohort_hydr%z_lower_ag + !write(fates_log(),*)'z troot: ', ccohort_hydr%z_node_troot return @@ -716,7 +731,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8) !! BOC not sure if/how we should multiply this by the sapwood fraction - ccohort_hydr%v_troot = v_troot / n_hypool_troot + ccohort_hydr%v_troot = v_troot / n_hypool_troot ! Estimate absorbing root total length (all layers) @@ -753,6 +768,12 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) end if end if + !write(fates_log(),*)'vols: ', ccohort_hydr%v_ag,ccohort_hydr%v_troot + !write(fates_log(),*)'v_aroot: ', ccohort_hydr%v_aroot_layer(:) + !write(fates_log(),*)'l_aroot: ', ccohort_hydr%l_aroot_layer(:) + + + end if !check for bleaf @@ -1254,6 +1275,9 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! The water update is allocated proportionally to the root biomass, which could be updated ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). ! After the root water uptake, is_newly_recruited flag is set to false. + ! Note, this routine is not accounting for the normal water uptake of new plants + ! going forward, this routine accounts for the water that needs to be accounted for + ! as the plants pop into existance. ! ---------------------------------------------------------------------------------- ! Arguments @@ -1296,28 +1320,23 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) roota = EDPftvarcon_inst%roota_par(ft) rootb = EDPftvarcon_inst%rootb_par(ft) recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n*AREA_INV/dtime + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n*AREA_INV/dtime recruitw_total = recruitw_total + recruitw - if( csite_hydr%nlevsoi_hyd == 1) then - csite_hydr%recruit_w_uptake(1) = csite_hydr%recruit_w_uptake(1)+ & - recruitw - else - do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, & - bc_in(s)%zi_sisl(j), bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j), & - bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1), & - bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - end if - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - recruitw*rootfr - end do - end if + do j=1,csite_hydr%nlevsoi_hyd + if(j == 1) then + rootfr = zeng2001_crootfr(roota, rootb, & + bc_in(s)%zi_sisl(j), bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j), & + bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1), & + bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) + end if + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + recruitw*rootfr + end do ccohort_hydr%is_newly_recruited = .false. endif currentCohort=>currentCohort%shorter @@ -1332,8 +1351,14 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake enddo + write(fates_log(),*) 'math check on recruit water failed.' + call endrun(msg=errMsg(sourcefile, __LINE__)) endif end do ! site loop + + !write(fates_log(),*) 'Calculating recruit water' + !write(fates_log(),*) csite_hydr%recruit_w_uptake + end subroutine RecruitWUptake @@ -1549,6 +1574,14 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) end if !has l_aroot_layer changed? enddo ! loop over soil layers +! write(fates_log(),*) '-----site geom------' +! do j=1,csite_hydr%nlevsoi_hyd +! write(fates_log(),*) 'j: ',j +! write(fates_log(),*) 'l_aroot: ',csite_hydr%l_aroot_layer(j) +! write(fates_log(),*) 'kmax_upper_shell(j,:):',csite_hydr%kmax_upper_shell(j,:) +! write(fates_log(),*) 'kmax_lower_shell(j,:):',csite_hydr%kmax_lower_shell(j,:) +! end do + return end subroutine UpdateSizeDepRhizVolLenCon @@ -1782,18 +1815,15 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) ! balance check do j = 1,csite_hydr%nlevsoi_hyd - ! BOC: PLEASE CHECK UNITS ON h2o_liq_sisl(j) (RGK) errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j) if (abs(errh2o(j)) > 1.e-4_r8) then - found = .true. - indexj = j - if( found ) then - write(fates_log(),*)'WARNING: water balance error ',& - ' local indexj= ',indexj,& - ' errh2o= ',errh2o(indexj) - end if + write(fates_log(),*)'WARNING: water balance error ',& + ' updating rhizosphere shells: ',j,errh2o(j) + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if enddo + end if !nshell > 1 end subroutine updateSizeDepRhizHydStates @@ -1913,12 +1943,8 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) do j = 1,csite_hydr%nlevsoi_hyd cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV - if(csite_hydr%nlevsoi_hyd == 1) then - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(bc_in(s)%nlevsoil) - cumShellH2O - else ! if(csite_hydr%nlevsoi_hyd == bc_in(s)%nlevsoil ) then - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j) - cumShellH2O - end if - + dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j) - cumShellH2O + dwat_kg = dwat_kgm2 * AREA ! order shells in terms of increasing or decreasing volumetric water content @@ -1981,23 +2007,15 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) enddo ! balance check - if(csite_hydr%nlevsoi_hyd .ne. 1) then - do j = 1,csite_hydr%nlevsoi_hyd - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) - - if (abs(errh2o(j)) > 1.e-9_r8) then - found = .true. - indexj = j - if( found ) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells',& - ' local indexj= ',indexj,& - ' errh2o= ',errh2o(indexj) - end if - end if - enddo - else - errh2o(csite_hydr%nlevsoi_hyd) = sum(h2osoi_liq_shell(csite_hydr%nlevsoi_hyd,:))*AREA_INV - sum( bc_in(s)%h2o_liq_sisl(:) ) - end if + do j = 1,csite_hydr%nlevsoi_hyd + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) + + if (abs(errh2o(j)) > 1.e-9_r8) then + write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + enddo end do return @@ -2124,6 +2142,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: iter ! number of solver iterations used for each cohort x layer integer :: nsteps ! number of substeps used for the final iteration on linear solve + real(r8) :: root_flux + real(r8) :: transp_flux + real(r8) :: delta_plant_storage + real(r8) :: delta_soil_storage + type(ed_site_hydr_type), pointer :: site_hydr type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: err_code = 0 @@ -2163,6 +2186,23 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%errh2o_hyd = 0._r8 prev_h2oveg = site_hydr%h2oveg + + ! Initialize water mass balancing terms [kg h2o / m2] + ! -------------------------------------------------------------------------------- + transp_flux = 0._r8 + root_flux = 0._r8 + + ! Initialize the delta in soil water and plant water storage + ! with the initial condition. + + delta_plant_storage = site_hydr%h2oveg + delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV + + !err_soil = delta_soil_storage - root_flux + !err_plot = delta_plant_storage - (root_flux - transp_flux) + + ! Calculate the mean site level transpiration flux ! This is usefull to check on mass conservation ! of cohort level fluxes @@ -2233,6 +2273,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime + transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV + ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS ! _____ ! | | @@ -2297,11 +2339,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) end if ! Get matric potential [Mpa] of the absorbing root - call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+2), & + call psi_from_th(ccohort%pft, aroot_p_media, & ccohort_hydr%th_aroot(j), psi_aroot, site_hydr, bc_in(s)) ! Get Fraction of Total Conductivity [-] of the absorbing root - call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+2), & + call flc_from_psi(ccohort%pft, aroot_p_media, & psi_aroot, ftc_aroot, site_hydr, bc_in(s)) ! Calculate total effective conductance over path [kg s-1 MPa-1] @@ -2392,8 +2434,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Change in water per plant [kg/plant] dwat_veg_coh = & (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o + dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o ! Accumulate site level diagnosti of plant water change site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV @@ -2440,18 +2482,17 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo ! Update water potential of transporting root compartment - k = n_hypool_ag+1 - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_troot, & + call psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot, & ccohort_hydr%psi_troot, site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_troot, & + call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, & ccohort_hydr%ftc_troot, site_hydr, bc_in(s)) - ! Update water potential of absorbing root root compartment + ! Update water potential of absorbing root compartment do j=1,site_hydr%nlevsoi_hyd - call psi_from_th(ft, porous_media(n_hypool_ag+2), & + call psi_from_th(ft, aroot_p_media, & ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j), & site_hydr, bc_in(s)) - call flc_from_psi(ft, porous_media(n_hypool_ag+2), & + call flc_from_psi(ft, aroot_p_media, & ccohort_hydr%psi_aroot(j), ccohort_hydr%ftc_aroot(j), & site_hydr, bc_in(s)) @@ -2488,10 +2529,15 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) (bc_in(s)%watsat_sisl(j)-small_theta_num)) then site_hydr%supsub_flag(j) = k site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num + print*,"SUPERSATURATED" + stop + else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & (watres_local+small_theta_num)) then site_hydr%supsub_flag(j) = -k site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num + print*,"SUBRESIDUAL" + stop else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & dth_layershell_col(j,k) @@ -2505,11 +2551,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) bc_in(s)%bsw_sisl(j), smp) site_hydr%psisoi_liq_innershell(j) = smp + !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) bc_out(s)%qflx_soil2root_sisl(j) = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) - + ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) @@ -2520,16 +2567,45 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo !site_hydr%nlevsoi_hyd + + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + + + delta_plant_storage = site_hydr%h2oveg - delta_plant_storage + + delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV - delta_soil_storage + + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-9_r8 ) then + write(fates_log(),*) 'Site plant water balance does not close' + write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' + write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' + write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' + write(fates_log(),*) 'end storage: ',site_hydr%h2oveg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(abs(delta_soil_storage + root_flux) > 1.e-9_r8 ) then + write(fates_log(),*) 'Site soil water balance does not close' + write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' + write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' + write(fates_log(),*) 'end storage: ',sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV, & + ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + !----------------------------------------------------------------------- ! mass balance check and pass the total stored vegetation water to HLM ! in order for it to fill its balance checks !remove the recruitment water uptake as it has been added to prev_h2oveg - totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:)- & + totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:) - & site_hydr%recruit_w_uptake(:))*dtime - wb_error_site = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake ) + wb_error_site = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - transp_flux) site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site @@ -2538,6 +2614,13 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err + !write(fates_log(),*) 'hydro wb terms: --------------------------' + !write(fates_log(),*) site_hydr%h2oveg + !write(fates_log(),*) site_hydr%h2oveg_dead + !write(fates_log(),*) site_hydr%h2oveg_growturn_err + !write(fates_log(),*) site_hydr%h2oveg_pheno_err + !write(fates_log(),*) site_hydr%h2oveg_hydro_err + enddo !site @@ -2785,6 +2868,13 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) end do + !write(fates_log(),*) 'ksu:',ccohort_hydr%kmax_stem_upper(:) + !write(fates_log(),*) 'ksl:',ccohort_hydr%kmax_stem_lower(:) + !write(fates_log(),*) 'ktu: ',ccohort_hydr%kmax_troot_upper + !write(fates_log(),*) 'ktl:',ccohort_hydr%kmax_troot_lower(:) + !write(fates_log(),*) 'kau',ccohort_hydr%kmax_aroot_upper(:) + !write(fates_log(),*) 'kri:',ccohort_hydr%kmax_aroot_radial_in(:) + !write(fates_log(),*) 'kro:',ccohort_hydr%kmax_aroot_radial_out(:) return end subroutine UpdatePlantKmax @@ -2820,6 +2910,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Locals integer :: inode ! node index "i" integer :: jpath ! path index "j" + integer :: itest ! node index used for testing and reporting errors integer :: ishell ! rhizosphere shell index of the node integer :: ishell_up ! rhizosphere shell index on the upper side of flow path integer :: ishell_lo ! rhizosphere shell index on the lower side of flow path @@ -2849,6 +2940,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] + real(r8) :: k_diag(n_hypool_tot-1) ! mean time-averaged K over the paths (diagnostic) [kg s-1 Mpa-1] + real(r8) :: flux_diag(n_hypool_tot-1) ! time-integrated mass flux over sub-steps [kg] real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta @@ -2947,11 +3040,16 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! If debugging, then lets re-initialize our diagnostics of + ! time integrated K and flux across the paths + if(debug)then + k_diag = 0._r8 + flux_diag = 0._r8 + end if ! For each attempt, we want to reset theta with the initial value th_node(:) = th_node_init(:) - ! Determine how many substeps, and how long they are nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep @@ -2973,6 +3071,13 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & psi_node(inode), site_hydr, bc_in) + if(psi_node(inode)>0._r8) then + write(fates_log(),*) 'positive psi?' + write(fates_log(),*) inode,ilayer,psi_node(inode),th_node(inode),th_node_init(inode) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Get total potential [Mpa] h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) @@ -3216,6 +3321,17 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t A_term(inode)*dth_node(inode) + & ! dq at node i B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + ! If debug mode is on, lets also track the mass fluxes across each + ! path, and keep a running average of the effective conductances + if(debug)then + do jpath=1,n_hypool_tot-1 + k_diag(jpath) = k_diag(jpath) + k_eff(jpath)*dt_substep/dt_step + flux_diag(jpath) = flux_diag(jpath) + dt_substep * ( & + k_eff(jpath)*(h_node(jpath+1)-h_node(jpath)) + & + A_term(jpath)*dth_node(jpath)+ B_term(jpath)*dth_node(jpath+1)) + end do + end if + end do ! do istep = 1,nsteps (substep loop) @@ -3223,7 +3339,31 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do - + + ! Do some checks on weird values. + if(debug)then + do inode = 1,n_hypool_tot + ! Get matric potential [Mpa] + call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & + psi_node(inode), site_hydr, bc_in) + ! Positive psi values are def weird + if(psi_node(inode) > 0._r8) then + write(fates_log(),*) 'positive psi found, dumping network' + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'total root length: ',sum(cohort_hydr%l_aroot_layer) + write(fates_log(),*) 'dt_substep: ',dt_substep + write(fates_log(),*) 'i theta_init theta mass' + do itest = 1,n_hypool_tot + write(fates_log(),*) itest,th_node_init(itest),th_node(itest),psi_node(itest),th_node(itest)*v_node(itest)*denh2o + if(itest 1) then (THIS BEING CHECKED INSIDE OF the update) - ! call updateSizeDepRhizHydStates(currentSite, c, soilstate_inst, & - ! waterstate_inst) - ! end if end if end if From 71f2bacfaabbe39f1ee53b60a5171fadcd01baf9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Sep 2019 15:12:35 -0700 Subject: [PATCH 017/114] Hydro refactors, more, unit fixes. --- biogeophys/FatesPlantHydraulicsMod.F90 | 35 +++++++++++++++++++++++--- main/EDPftvarcon.F90 | 25 +++++++++++++++++- 2 files changed, 56 insertions(+), 4 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 92f5459fbe..5365fa4166 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -735,8 +735,11 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! Estimate absorbing root total length (all layers) + ! SRL is in m/g + ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*g_per_kg*C2B*EDPftvarcon_inst%hydr_srl(ft) + ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ @@ -2680,6 +2683,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways ! [kg-1 s MPa] real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + real(r8) :: kmax_bg_alt ! from the absorbing roots center nodes to the ! transporting root center node real(r8) :: rootfr ! fraction of absorbing root in each soil layer @@ -2783,7 +2787,6 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & xylemtaper(taper_exponent, z_node) * & a_sapwood / z_node @@ -2794,6 +2797,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + !print*,z_upper,z_node,kmax_upper,kmax_node,ccohort_hydr%kmax_troot_upper + ! The maximum conductance between the center node of the transporting root ! compartment, and the center node of the absorbing root compartment, is calculated @@ -2814,7 +2819,16 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! Calculate the residual resistance below ground, as a resistor ! in series with the existing above ground ! Invert to find below-ground kmax - kmax_bg = 1._r8/(rmin_ag * (1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) + ! (rmin_ag+rmin_bg)*fr = rmin_ag + ! rmin_ag + rmin_bg = rmin_ag/fr + ! rmin_bg = (1/fr-1) * rmin_ag + ! + ! if kmax_bg = 1/rmin_bg : + ! + ! kmax_bg = 1/((1/fr-1) * rmin_ag) + + kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) + ! The max conductance of each layer is in parallel, therefore ! the kmax terms of each layer, should sum to kmax_bg @@ -2949,6 +2963,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] + real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) + real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) ! out of the total absorbing roots from the whole community of plants, integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps @@ -2957,6 +2973,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8), parameter :: max_wb_step_err = 1.e-6_r8 real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] + logical, parameter :: do_scale_allkmax_rootfr = .true. + + ! ------------------------------------------------------------------------------- ! Part 1. Calculate node quantities: ! matric potential: psi_node @@ -3351,6 +3370,16 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t write(fates_log(),*) 'positive psi found, dumping network' write(fates_log(),*) 'dbh: ',cohort%dbh write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'soil layer:',ilayer + roota=EDPftvarcon_inst%roota_par(cohort%pft) + rootb=EDPftvarcon_inst%rootb_par(cohort%pft) + if(ilayer==1) then + rootfr = zeng2001_crootfr(roota,rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + else + rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer-1), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + end if + write(fates_log(),*) 'rootfrac: ', rootfr write(fates_log(),*) 'total root length: ',sum(cohort_hydr%l_aroot_layer) write(fates_log(),*) 'dt_substep: ',dt_substep write(fates_log(),*) 'i theta_init theta mass' diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0e4a9f7720..955e8e1119 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1978,6 +1978,8 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! end if + + ! Check if the fraction of storage used for flushing deciduous trees ! is greater than zero, and less than or equal to 1. @@ -2395,7 +2397,28 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - end do + end do + +!! ! Checks for HYDRO +!! if( hlm_use_planthydro == itrue ) then +!! +!! do ipft=1,numpft +!! +!! ! Calculate fine-root density and see if the result +!! ! is reasonable. +!! ! kg/m3 +!! +!! dens_aroot = 1._r8/(g_per_kg*pi_const*EDPftvarcon_inst%hydr_rs2(ipft)**2.0_r8*EDPftvarcon_inst%hydr_srl(ipft)) +!! +!! if(rho_aroot>max_dens_aroot .or. dens_aroot Date: Mon, 9 Sep 2019 15:13:04 -0700 Subject: [PATCH 018/114] More hydro refactors --- biogeophys/FatesPlantHydraulicsMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5365fa4166..0dc52137cc 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2711,6 +2711,9 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) + + + ! Leaf Maximum Hydraulic Conductance ! The starting hypothesis is that there is no resistance inside the ! leaf, between the petiole and the center of storage. To override From c6dcb5f4f00f27d8993e092abdab489b2a90a207 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Sep 2019 15:34:04 -0700 Subject: [PATCH 019/114] Forcing rs1=rs2 temporarily --- main/FatesHydraulicsMemMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 1e8ab8a642..c48687054b 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -61,7 +61,7 @@ module FatesHydraulicsMemMod integer, parameter, public :: nlevcan_hyd = 2 ! Mean fine root radius expected in the bulk soil - real(r8), parameter, public :: fine_root_radius_const = 0.001_r8 + real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 ! Constant parameters (for time being, C2B is constant, ! slated for addition to parameter file (RGK 08-2017)) From a6ad7f4247f1ad6d6e9149c53ed9cc57ebb1f1b4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 10 Sep 2019 17:49:01 -0700 Subject: [PATCH 020/114] hydraulics refactor: generalized th/psi/flc transforms a little, more diagnostics --- biogeophys/FatesPlantHydraulicsMod.F90 | 167 ++++++++++++++++--------- main/FatesHydraulicsMemMod.F90 | 2 +- 2 files changed, 109 insertions(+), 60 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 0dc52137cc..046035e56f 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -353,9 +353,9 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equalibrium between soil and root call th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%th_aroot(j), csite%si_hydr, bc_in ) + ccohort_hydr%th_aroot(j)) call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%ftc_aroot(j), csite%si_hydr, bc_in) + ccohort_hydr%ftc_aroot(j)) end do @@ -369,8 +369,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 - call th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, & - ccohort_hydr%th_troot, csite%si_hydr, bc_in) + call th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%th_troot) call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) !working our way up a tree, assigning water potentials that are in @@ -379,16 +378,16 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 call th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & - ccohort_hydr%th_ag(n_hypool_ag), csite%si_hydr, bc_in) + ccohort_hydr%th_ag(n_hypool_ag)) call flc_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & ccohort_hydr%ftc_ag(n_hypool_ag)) do k=n_hypool_ag-1, 1, -1 dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) - ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - 1.e-6_r8*denh2o*grav_earth*dz + ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - mpa_per_pa*denh2o*grav_earth*dz if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%th_ag(k), csite%si_hydr, bc_in) + ccohort_hydr%th_ag(k)) call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k),ccohort_hydr%ftc_ag(k)) end do @@ -1006,9 +1005,9 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne do j=1,site_hydr%nlevsoi_hyd call psi_from_th(currentCohort%pft, aroot_p_media, ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j), site_hydr, bc_in) + ccohort_hydr%psi_aroot(j)) call flc_from_psi(currentCohort%pft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%ftc_aroot(j), site_hydr, bc_in) + ccohort_hydr%ftc_aroot(j)) end do call flc_gs_from_psi(currentCohort, ccohort_hydr%psi_ag(1)) @@ -2252,6 +2251,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + write(fates_log(),*) 'q patch: ',bc_in(s)%qflx_transp_pa(ifp) + ccohort=>cpatch%tallest do while(associated(ccohort)) @@ -2329,8 +2331,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! required. call psi_from_th(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,1), & - psi_inner_shell, site_hydr, bc_in(s)) + site_hydr%h2osoi_liqvol_shell(j,1), & + psi_inner_shell, & + bc_in(s)%watsat_sisl(j), & ! optional for soil + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) ! optional for soil + ! Note, since their is no elevation difference between ! the absorbing root and its layer, no need to calc @@ -2343,11 +2349,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Get matric potential [Mpa] of the absorbing root call psi_from_th(ccohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j), psi_aroot, site_hydr, bc_in(s)) + ccohort_hydr%th_aroot(j), psi_aroot) ! Get Fraction of Total Conductivity [-] of the absorbing root call flc_from_psi(ccohort%pft, aroot_p_media, & - psi_aroot, ftc_aroot, site_hydr, bc_in(s)) + psi_aroot, ftc_aroot) ! Calculate total effective conductance over path [kg s-1 MPa-1] ! from absorbing root node to 1st rhizosphere shell @@ -2362,10 +2368,16 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - call psi_from_th(ccohort%pft, porous_media(n_hypool_ag+3), & - site_hydr%h2osoi_liqvol_shell(j,k), psi_shell, site_hydr, bc_in(s)) - call flc_from_psi(ccohort%pft, porous_media(n_hypool_ag+3), & - psi_shell, ftc_shell, site_hydr, bc_in(s)) + call psi_from_th(ccohort%pft, rhiz_p_media, & + site_hydr%h2osoi_liqvol_shell(j,k), psi_shell, & + bc_in(s)%watsat_sisl(j), & ! optional for soil + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) + + call flc_from_psi(ccohort%pft, rhiz_p_media, & + psi_shell, ftc_shell, & + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) ! optional for soil r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) if(k ccohort%shorter @@ -2959,6 +2968,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] real(r8) :: k_diag(n_hypool_tot-1) ! mean time-averaged K over the paths (diagnostic) [kg s-1 Mpa-1] real(r8) :: flux_diag(n_hypool_tot-1) ! time-integrated mass flux over sub-steps [kg] + real(r8) :: h_diag, psi_diag ! total and matric potential for error reporting [Mpa] real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta @@ -3091,7 +3101,10 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Get matric potential [Mpa] call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & - psi_node(inode), site_hydr, bc_in) + psi_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil if(psi_node(inode)>0._r8) then write(fates_log(),*) 'positive psi?' @@ -3105,14 +3118,21 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Get Fraction of Total Conductivity [-] call flc_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & - ftc_node(inode), site_hydr, bc_in) + ftc_node(inode), & + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil ! deriv ftc wrt theta call dpsidth_from_th(cohort%pft, porous_media(inode), th_node(inode), & - dpsi_dtheta_node(inode), site_hydr, bc_in) + dpsi_dtheta_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil call dflcdpsi_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & - dftc_dpsi, site_hydr, bc_in) + dftc_dpsi, & + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil dftc_dtheta_node(inode) = dftc_dpsi * dpsi_dtheta_node(inode) @@ -3367,13 +3387,21 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t do inode = 1,n_hypool_tot ! Get matric potential [Mpa] call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & - psi_node(inode), site_hydr, bc_in) + psi_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil ! Positive psi values are def weird if(psi_node(inode) > 0._r8) then write(fates_log(),*) 'positive psi found, dumping network' write(fates_log(),*) 'dbh: ',cohort%dbh write(fates_log(),*) 'pft: ',cohort%pft write(fates_log(),*) 'soil layer:',ilayer + write(fates_log(),*) 'qtop [kg]:',q_top*dt_step + write(fates_log(),*) 'q patch: ',bc_in%qflx_transp_pa(:) + write(fates_log(),*) 'g_sb_laweight: ',cohort%g_sb_laweight + write(fates_log(),*) 'lai: ',cohort%treelai + write(fates_log(),*) 'rs2:',EDPftvarcon_inst%hydr_rs2(cohort%pft) roota=EDPftvarcon_inst%roota_par(cohort%pft) rootb=EDPftvarcon_inst%rootb_par(cohort%pft) if(ilayer==1) then @@ -3387,9 +3415,23 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t write(fates_log(),*) 'dt_substep: ',dt_substep write(fates_log(),*) 'i theta_init theta mass' do itest = 1,n_hypool_tot - write(fates_log(),*) itest,th_node_init(itest),th_node(itest),psi_node(itest),th_node(itest)*v_node(itest)*denh2o + ! get initial total potential of node: + call psi_from_th(cohort%pft, porous_media(itest), th_node_init(itest), & + psi_diag, & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil + + h_diag = psi_diag + mpa_per_pa*denh2o*grav_earth*z_node(itest) + write(fates_log(),*) 'node',itest,th_node_init(itest),th_node(itest),psi_node(itest),v_node(itest),h_diag,psi_diag if(itest cc_p - FT = cCohort%pft - ccohort%co_hydr%btran = & - (1._r8 + (lwp/EDPftvarcon_inst%hydr_p50_gs(ft))**EDPftvarcon_inst%hydr_avuln_gs(ft))**(-1._r8) - end subroutine flc_gs_from_psi - - !-------------------------------------------------------------------------------! - subroutine dflcgsdpsi_from_psi(lwp, ft, dflcgsdpsi) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: lwp ! leaf water potential (MPa) - integer , intent(in) :: ft ! leaf pft - real(r8) , intent(out) :: dflcgsdpsi ! fractional loss of conductivity [-] - - !---------------------------------------------------------------------- - - associate(& - avuln_gs => EDPftvarcon_inst%hydr_avuln_gs, & ! Input: [real(r8) (:) ] stomatal PLC curve: shape parameter [-] - p50_gs => EDPftvarcon_inst%hydr_p50_gs & ! Input: [real(r8) (:) ] stomatal PLC curve: water potential at 50% loss of gs,max [Pa] - ) - - dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(FT))**avuln_gs(FT))**(-2._r8) * & - avuln_gs(FT)/p50_gs(FT)*(lwp/p50_gs(FT))**(avuln_gs(FT)-1._r8) - - end associate - -end subroutine dflcgsdpsi_from_psi - -!-------------------------------------------------------------------------------! -subroutine flc_from_psi(ft, pm, psi_node, flc_node, suc_sat, bsw) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: psi_node ! water potential [MPa] - real(r8) , intent(out) :: flc_node ! fractional loss of conductivity [-] - real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] - real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" - - ! - ! !LOCAL VARIABLES: - - !---------------------------------------------------------------------- - - associate(& - avuln => EDPftvarcon_inst%hydr_avuln_node , & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] - p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] - ) - - if(pm <= 4) then - flc_node = 1._r8/(1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm)) - else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call unsatkVG_flc_from_psi(psi_node, & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! flc_node) - case (campbell) - call unsatkCampbell_flc_from_psi(psi_node, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - flc_node) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - -end associate - -end subroutine flc_from_psi - -!-------------------------------------------------------------------------------! -subroutine dflcdpsi_from_psi(ft, pm, psi_node, dflcdpsi_node, suc_sat, bsw) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: psi_node ! water potential [MPa] -real(r8) , intent(out) :: dflcdpsi_node ! fractional loss of conductivity [-] -real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] -real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" - - -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& - avuln => EDPftvarcon_inst%hydr_avuln_node, & ! Input: [real(r8) (:,:) ] PLC curve: vulnerability curve shape parameter [-] - p50 => EDPftvarcon_inst%hydr_p50_node & ! Input: [real(r8) (:,:) ] PLC curve: water potential at 50% loss of conductivity [Pa] - ) - -if(pm <= 4) then - dflcdpsi_node = -1._r8 * (1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm))**(-2._r8) * & - avuln(ft,pm)/p50(ft,pm)*(psi_node/p50(ft,pm))**(avuln(ft,pm)-1._r8) -else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !call unsatkVG_dflcdpsi_from_psi(psi_node, & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! dflcdpsi_node) - case (campbell) - call unsatkCampbell_dflcdpsi_from_psi(psi_node, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - dflcdpsi_node) - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select -end if - -end associate - -end subroutine dflcdpsi_from_psi - -!-------------------------------------------------------------------------------! -subroutine th_from_psi(ft, pm, psi_node, th_node, site_hydr, bc_in) - ! - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to volumetric water contents - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: psi_node ! water potential [MPa] -real(r8) , intent(out) :: th_node ! water content [m3 m-3] -type(ed_site_hydr_type), optional,intent(in),target :: site_hydr ! ED site_hydr structure -type(bc_in_type), optional, intent(in) :: bc_in ! FATES boundary conditions - -! -! !LOCAL VARIABLES: -real(r8) :: lower ! lower bound of initial estimate [m3 m-3] -real(r8) :: upper ! upper bound of initial estimate [m3 m-3] -real(r8) :: xtol ! error tolerance for x-variable [m3 m-3] -real(r8) :: ytol ! error tolerance for y-variable [MPa] -real(r8) :: satfrac ! soil saturation fraction [0-1] -real(r8) :: psi_check - -!---------------------------------------------------------------------- - -associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction - ) - -if(pm <= 4) then - - lower = thetas(ft,pm)*(resid(ft,pm) + 0.0001_r8)/cap_corr(pm) - upper = thetas(ft,pm) - xtol = 1.e-16_r8 - ytol = 1.e-8_r8 - call bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) - call psi_from_th(ft, pm, th_node, psi_check ) - - if(psi_check > -1.e-8_r8) then - write(fates_log(),*)'bisect_pv returned positive value for water potential at pm = ', char(pm) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - -else - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call swcVG_satfrac_from_psi(psi_node, & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! satfrac) - ! call swcVG_th_from_satfrac(satfrac, & - ! bc_in%watsat_sisl(1), & - ! bc_in%watres_sisl(1), & - ! th_node) - case (campbell) - - call swcCampbell_satfrac_from_psi(psi_node, & - (-1._r8)*bc_in%sucsat_sisl(1)*denh2o*grav_earth*1.e-9_r8, & - bc_in%bsw_sisl(1), & - satfrac) - call swcCampbell_th_from_satfrac(satfrac, & - bc_in%watsat_sisl(1), & - th_node) - case default - write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select -end if - -end associate - -end subroutine th_from_psi - -!-------------------------------------------------------------------------------! -subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. - ! An analytical solution is not possible because quadratic smoothing functions - ! are used to remove discontinuities in the PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(inout) :: lower ! lower bound of estimate [m3 m-3] -real(r8) , intent(inout) :: upper ! upper bound of estimate [m3 m-3] -real(r8) , intent(in) :: xtol ! error tolerance for x-variable [m3 m-3] -real(r8) , intent(in) :: ytol ! error tolerance for y-variable [MPa] -real(r8) , intent(in) :: psi_node ! water potential [MPa] -real(r8) , intent(out) :: th_node ! water content [m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: x_new ! new estimate for x in bisection routine -real(r8) :: y_lo ! corresponding y value at lower -real(r8) :: f_lo ! y difference between lower bound guess and target y -real(r8) :: y_hi ! corresponding y value at upper -real(r8) :: f_hi ! y difference between upper bound guess and target y -real(r8) :: y_new ! corresponding y value at x.new -real(r8) :: f_new ! y difference between new y guess at x.new and target y -real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) -integer :: nitr ! number of iterations -!---------------------------------------------------------------------- -if(psi_node > 0.0_r8) then -write(fates_log(),*)'Error: psi_note become positive, psi_node=',psi_node -call endrun(msg=errMsg(sourcefile, __LINE__)) -endif -call psi_from_th(ft, pm, lower, y_lo) -call psi_from_th(ft, pm, upper, y_hi) -f_lo = y_lo - psi_node -f_hi = y_hi - psi_node -chg = upper - lower -nitr = 0 -do while(abs(chg) .gt. xtol .and. nitr < 100) -x_new = 0.5_r8*(lower + upper) -call psi_from_th(ft, pm, x_new, y_new) -f_new = y_new - psi_node -if(abs(f_new) .le. ytol) then - EXIT -end if -if((f_lo * f_new) .lt. 0._r8) upper = x_new -if((f_hi * f_new) .lt. 0._r8) lower = x_new -chg = upper - lower -nitr = nitr + 1 -end do - -if(nitr .eq. 100)then -write(fates_log(),*)'Warning: number of iteraction reaches 100 for bisect_pv' -endif - -th_node = x_new - -end subroutine bisect_pv - -!-------------------------------------------------------------------------------! -subroutine psi_from_th(ft, pm, th_node, psi_node, th_sat, suc_sat, bsw) - - ! - ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) - ! at a given water content (th) - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: th_node ! water content [m3 m-3] -real(r8) , intent(out) :: psi_node ! water potential [MPa] -real(r8), optional,intent(in) :: th_sat ! water content at saturation - ! (porosity for soil) [m3 m-3] -real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] -real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" - -! -! !LOCAL VARIABLES: -real(r8) :: satfrac ! saturation fraction [0-1] -!---------------------------------------------------------------------- - -if(pm <= 4) then ! plant - -call tq2(ft, pm, th_node*cap_corr(pm), psi_node) - -else if(pm == 5) then ! soil - - !! NOTE. FIX: The below sidesteps the problem of averaging potentially variable soil hydraulic properties with depth - !! and simply assigns the bulk soil (bucket) approximation of hydraulic properties as equal to the top soil layer. -select case (iswc) -case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call swcVG_psi_from_th(th_node, & - ! bc_in%watsat_sisl(1), & - ! bc_in%watres_sisl(1), & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! psi_node) -case (campbell) - call swcCampbell_psi_from_th(th_node,th_sat, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - psi_node) -case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) -end select - -end if - -end subroutine psi_from_th - -!-------------------------------------------------------------------------------! -subroutine dpsidth_from_th(ft, pm, th_node, y, th_sat, suc_sat, bsw) - ! - ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) - ! at a given water content (th) - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: th_node ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -real(r8), optional,intent(in) :: th_sat ! water content at saturation - ! (porosity for soil) [m3 m-3] -real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] -real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" - -! -! !LOCAL VARIABLES: - -real(r8) :: satfrac ! saturation fraction [0-1] -!---------------------------------------------------------------------- - -if(pm <= 4) then ! plant -call dtq2dth(ft, pm, th_node*cap_corr(pm), y) -else if(pm == 5) then ! soil -select case (iswc) -case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - !call swcVG_dpsidth_from_th(th_node, & - ! bc_in%watsat_sisl(1), & - ! bc_in%watres_sisl(1), & - ! site_hydr%alpha_VG(1), & - ! site_hydr%n_VG(1), & - ! site_hydr%m_VG(1), & - ! site_hydr%l_VG(1), & - ! y) -case (campbell) - call swcCampbell_dpsidth_from_th(th_node, & - th_sat, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - y) -case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) -end select -end if - -end subroutine dpsidth_from_th - -!-------------------------------------------------------------------------------! -subroutine tq2(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_bq2 ! returned y (psi) value from bq2() -real(r8) :: y_cq2 ! returned y (psi) value from cq2() -real(r8) :: beta2=0.99_r8 ! smoothing factor -!---------------------------------------------------------------------- - -call bq2(ft, pm, x, y_bq2) -call cq2(ft, pm, x, y_cq2) -y = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2*beta2) - -end subroutine tq2 - -!-------------------------------------------------------------------------------! -subroutine dtq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: y_bq2 ! returned y (psi) value from bq2() -real(r8) :: y_cq2 ! returned y (psi) value from cq2() -real(r8) :: dydth_bq2 ! returned derivative from dbq2dth() -real(r8) :: dydth_cq2 ! returned derivative from dcq2dth() -real(r8) :: beta2=0.99_r8 ! smoothing factor -!---------------------------------------------------------------------- - -call bq2(ft, pm, x, y_bq2) -call cq2(ft, pm, x, y_cq2) -call dbq2dth(ft, pm, x, dydth_bq2) -call dcq2dth(ft, pm, x, dydth_cq2) -y = 1._r8/(2._r8*beta2)*(-dydth_bq2 + 0.5_r8*((y_bq2*y_bq2 - 4._r8*beta2*y_cq2)**(-0.5_r8)) * & - (2._r8*y_bq2*dydth_bq2 - 4._r8*beta2*dydth_cq2)) - -end subroutine dtq2dth - -!-------------------------------------------------------------------------------! -subroutine bq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_tq1 ! returned y (psi) value from tq1() -real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() -!---------------------------------------------------------------------- - -call tq1(ft, pm, x, y_tq1) -call cavitationPV(ft, pm, x, y_cavitation) -y = -1._r8*(y_tq1 + y_cavitation) - -end subroutine bq2 - -!-------------------------------------------------------------------------------! -subroutine dbq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() -real(r8) :: dcavdth ! returned derivative from dcavitationdth() -!---------------------------------------------------------------------- - -call dtq1dth(ft, pm, x, dydth_tq1) -call dcavitationPVdth(ft, pm, x, dcavdth) -y = -1._r8*(dydth_tq1 + dcavdth) - -end subroutine dbq2dth - -!-------------------------------------------------------------------------------! -subroutine cq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_tq1 ! returned y (psi) value from tq1() -real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() -!---------------------------------------------------------------------- - -call tq1(ft, pm, x, y_tq1) -call cavitationPV(ft, pm, x, y_cavitation) -y = y_tq1*y_cavitation - -end subroutine cq2 - -!-------------------------------------------------------------------------------! -subroutine dcq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq2() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: y_tq1 ! returned y (psi) value from tq1() -real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() -real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() -real(r8) :: dcavdth ! returned derivative from dcavitationdth() -!---------------------------------------------------------------------- - -call tq1(ft, pm, x, y_tq1) -call cavitationPV(ft, pm, x, y_cavitation) -call dtq1dth(ft, pm, x, dydth_tq1) -call dcavitationPVdth(ft, pm, x, dcavdth) -y = y_tq1*dcavdth + dydth_tq1*y_cavitation - -end subroutine dcq2dth - -!-------------------------------------------------------------------------------! -subroutine tq1(ft, pm, x, y) - ! - ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or - ! does a smoothing function for capillary-to-elastic region of the plant PV - ! curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_bq1 ! returned y (psi) value from bq1() -real(r8) :: y_cq1 ! returned y (psi) value from cq1() -real(r8) :: y_elastic ! returned y (psi) value from elasticPV() -real(r8) :: beta1=0.80_r8 ! smoothing factor -!---------------------------------------------------------------------- - -if(pm == 1) then ! leaves have no capillary region in their PV curves -call elasticPV(ft, pm, x, y_elastic) -y = y_elastic -else if(pm <= 4) then ! sapwood has a capillary region -call bq1(ft, pm, x, y_bq1) -call cq1(ft, pm, x, y_cq1) -y = (-y_bq1 - sqrt(y_bq1*y_bq1 - 4._r8*beta1*y_cq1))/(2*beta1) -end if !porous media - -end subroutine tq1 - -!-------------------------------------------------------------------------------! -subroutine dtq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of tq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: y_bq1 ! returned y (psi) value from bq1() -real(r8) :: y_cq1 ! returned y (psi) value from cq1() -real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() -real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() -real(r8) :: delasticdth ! returned derivative from delasticPVdth() -real(r8) :: beta1=0.80_r8 ! smoothing factor -!---------------------------------------------------------------------- - -if(pm == 1) then ! leaves have no capillary region in their PV curves -call delasticPVdth(ft, pm, x, delasticdth) -y = delasticdth -else if(pm <= 4) then ! sapwood has a capillary region -call bq1(ft, pm, x, y_bq1) -call cq1(ft, pm, x, y_cq1) -call dbq1dth(ft, pm, x, dydth_bq1) -call dcq1dth(ft, pm, x, dydth_cq1) -y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & - (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) -end if - -end subroutine dtq1dth - -!-------------------------------------------------------------------------------! -subroutine bq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() -real(r8) :: y_elastic ! returned y (psi) value from elasticPV() -!---------------------------------------------------------------------- - -call capillaryPV(ft, pm, x, y_capillary) -call elasticPV(ft, pm, x, y_elastic) -y = -1._r8*(y_capillary + y_elastic) - -end subroutine bq1 - -!-------------------------------------------------------------------------------! -subroutine dbq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of bq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() -real(r8) :: delasticdth ! returned derivative from delasticPVdth() -!---------------------------------------------------------------------- - -call dcapillaryPVdth(ft, pm, x, dcapdth) -call delasticPVdth(ft, pm, x, delasticdth) -y = -1._r8*(delasticdth + dcapdth) - -end subroutine dbq1dth - -!-------------------------------------------------------------------------------! -subroutine cq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() -real(r8) :: y_elastic ! returned y (psi) value from elasticPV() -!---------------------------------------------------------------------- - -call capillaryPV(ft, pm, x, y_capillary) -call elasticPV(ft, pm, x, y_elastic) -y = y_capillary*y_elastic - -end subroutine cq1 - -!-------------------------------------------------------------------------------! -subroutine dcq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() -real(r8) :: y_elastic ! returned y (psi) value from elasticPV() -real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() -real(r8) :: delasticdth ! returned derivative from delasticPVdth() -!---------------------------------------------------------------------- - -call capillaryPV(ft, pm, x, y_capillary) -call elasticPV(ft, pm, x, y_elastic) -call dcapillaryPVdth(ft, pm, x, dcapdth) -call delasticPVdth(ft, pm, x, delasticdth) -y = y_elastic*dcapdth + delasticdth*y_capillary - -end subroutine dcq1dth - -!-------------------------------------------------------------------------------! -subroutine cavitationPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_solute ! returned y (psi) value from solutepsi() -!---------------------------------------------------------------------- - -call solutepsi(ft, pm, x, y_solute) -y = y_solute - -end subroutine cavitationPV - -!-------------------------------------------------------------------------------! -subroutine dcavitationPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: dsoldth ! returned derivative from dsolutepsidth() -!---------------------------------------------------------------------- - -call dsolutepsidth(ft, pm, x, dsoldth) -y = dsoldth - -end subroutine dcavitationPVdth - -!-------------------------------------------------------------------------------! -subroutine elasticPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: y_solute ! returned y (psi) value from solutepsi() -real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() -!---------------------------------------------------------------------- - -call solutepsi(ft, pm, x, y_solute) -call pressurepsi(ft, pm, x, y_pressure) -y = y_solute + y_pressure - -end subroutine elasticPV - -!-------------------------------------------------------------------------------! -subroutine delasticPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of elasticPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -real(r8) :: dsoldth ! returned derivative from dsolutepsidth() -real(r8) :: dpressdth ! returned derivative from dpressurepsidth() -!---------------------------------------------------------------------- - -call dsolutepsidth(ft, pm, x, dsoldth) -call dpressurepsidth(ft, pm, x, dpressdth) -y = dsoldth + dpressdth - -end subroutine delasticPVdth - -!-------------------------------------------------------------------------------! -subroutine solutepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes solute water potential (negative) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& - pinot => EDPftvarcon_inst%hydr_pinot_node, & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) - -y = pinot(ft,pm)*thetas(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - (x - thetas(ft,pm)*resid(ft,pm)) - -end associate - -end subroutine solutepsi - -!-------------------------------------------------------------------------------! -subroutine dsolutepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of solutepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& -pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] -thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] -resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] -) - -y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & -((x - thetas(ft,pm)*resid(ft,pm))**2._r8) - -end associate - -end subroutine dsolutepsidth - -!-------------------------------------------------------------------------------! -subroutine pressurepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes pressure water potential (positive) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& -pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] -thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] -resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] -epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] -) - -y = epsil(ft,pm) * (x - thetas(ft,pm)*rwcft(pm)) / & -(thetas(ft,pm)*(rwcft(pm)-resid(ft,pm))) - pinot(ft,pm) - -end associate - -end subroutine pressurepsi - -!-------------------------------------------------------------------------------! -subroutine dpressurepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& -thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] -resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] -epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] -) - -y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) - -end associate - -end subroutine dpressurepsidth - -!-------------------------------------------------------------------------------! -subroutine capillaryPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the capillary region of the plant - ! PV curve (sapwood only) - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! water potential [MPa] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& -thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] -) - -y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x - -end associate - -end subroutine capillaryPV - -!-------------------------------------------------------------------------------! -subroutine dcapillaryPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS -integer , intent(in) :: ft ! PFT index -integer , intent(in) :: pm ! porous media index -real(r8) , intent(in) :: x ! water content [m3 m-3] -real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] -! -! !LOCAL VARIABLES: -!---------------------------------------------------------------------- - -associate(& -thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] -) - -y = cap_slp(pm)/thetas(ft,pm) - -end associate - -end subroutine dcapillaryPVdth - -!-------------------------------------------------------------------------------! -subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns saturation fraction given water content, porosity, and residual water content - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] -real(r8), intent(out) :: satfrac !saturation fraction [0-1] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -satfrac = (th - watres)/(watsat - watres) - -end subroutine swcVG_satfrac_from_th - -!-------------------------------------------------------------------------------! -subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns saturation fraction given water content and porosity - ! - !USES - !ARGUMENTS: -real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(out) :: satfrac !saturation fraction [0-1] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -satfrac = th/watsat - -end subroutine swcCampbell_satfrac_from_th - -!-------------------------------------------------------------------------------! -subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water potential given water content and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: th !volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: psi !soil matric potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: satfrac !saturation fraction [0-1] -!------------------------------------------------------------------------------ - -call swcVG_satfrac_from_th(th, watsat, watres, satfrac) -call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) - -end subroutine swcVG_psi_from_th - -!-------------------------------------------------------------------------------! -subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water potential given saturation fraction, air-entry pressure and shape parameter - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: th !volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: psisat !air entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: psi !soil matric potential [MPa] -! -! !LOCAL VARIABLES: -real(r8) :: satfrac !saturation fraction [0-1] -!------------------------------------------------------------------------------ - -call swcCampbell_satfrac_from_th(th, watsat, satfrac) -call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) - -end subroutine swcCampbell_psi_from_th - -!-------------------------------------------------------------------------------! -subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water potential given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: psi !soil matric potential [MPa] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) - -end subroutine swcVG_psi_from_satfrac - -!-------------------------------------------------------------------------------! -subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water potential given saturation fraction, air-entry pressure and shape parameter - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: psisat !air entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: psi !soil matric potential [MPa] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -psi = psisat*(satfrac**(-B)) - -end subroutine swcCampbell_psi_from_satfrac - -!-------------------------------------------------------------------------------! -subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water content given saturation fraction, porosity and residual water content - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] -real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -th = watres + satfrac*(watsat - watres) - -end subroutine swcVG_th_from_satfrac - -!-------------------------------------------------------------------------------! -subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water content given saturation fraction and porosity - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -th = satfrac*watsat - -end subroutine swcCampbell_th_from_satfrac - -!----------------------------------------------------------------------- -subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns saturation fraction given water potential and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m - -end subroutine swcVG_satfrac_from_psi - -!----------------------------------------------------------------------- -subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns saturation fraction given water potential and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: psisat !air-entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] -! -! !LOCAL VARIABLES: -!------------------------------------------------------------------------------ - -satfrac = (psi/psisat)**(-1.0_r8/B) - -end subroutine swcCampbell_satfrac_from_psi - -!----------------------------------------------------------------------- -subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given water content and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: th !volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] -! -! !LOCAL VARIABLES: -real(r8) :: satfrac !saturation fraction [0-1] -!------------------------------------------------------------------------------ - -call swcVG_satfrac_from_th(th, watsat, watres, satfrac) -call swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) - -end subroutine swcVG_dpsidth_from_th - -!----------------------------------------------------------------------- -subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given water content and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: th !volumetric water content [m3 m-3] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: psisat !air entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] -! -! !LOCAL VARIABLES: -real(r8) :: satfrac !saturation fraction [0-1] -!------------------------------------------------------------------------------ - -call swcCampbell_satfrac_from_th(th, watsat, satfrac) -call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) - -end subroutine swcCampbell_dpsidth_from_th - -!----------------------------------------------------------------------- -subroutine swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] -! -! !LOCAL VARIABLES: -real(r8) :: temp0 !temporary -real(r8) :: temp1 !temporary -real(r8) :: temp2 !temporary -real(r8) :: temp3 !temporary -!------------------------------------------------------------------------------ - -temp0 = 1._r8/(m*n*alpha*(watsat-watres)) -temp1 = satfrac**(-1._r8/m) - 1._r8 -temp2 = temp1**(1._r8/n - 1._r8) -temp3 = satfrac**(-1._r8/m - 1._r8) -dpsidth = temp0*temp2*temp3 - -end subroutine swcVG_dpsidth_from_satfrac - -!----------------------------------------------------------------------- -subroutine swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: satfrac !saturation fraction [0-1] -real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] -real(r8), intent(in) :: psisat !air-entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] -!------------------------------------------------------------------------------ - -dpsidth = psisat*(-B)/watsat*(satfrac)**(-B-1._r8) - -end subroutine swcCampbell_dpsidth_from_satfrac - -!----------------------------------------------------------------------- -subroutine unsatkVG_flc_from_psi(psi, alpha, n, m, l, flc) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns unsaturated hydraulic conductivity - ! given water potential and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] -! -! !LOCAL VARIABLES: -real(r8) :: temp !temporary -real(r8) :: fac1a !temporary -real(r8) :: fac1b !temporary -real(r8) :: fac1 !temporary -real(r8) :: fac2 !temporary -!------------------------------------------------------------------------------ - -temp = ( alpha*abs(psi) ) ** (n) -fac1a = ( alpha*abs(psi) ) ** (n-1._r8) -fac1b = ( 1._r8 + temp ) ** (-1._r8*m) -fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) -fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) - -flc = fac1 * fac2 - -end subroutine unsatkVG_flc_from_psi - -!----------------------------------------------------------------------- -subroutine unsatkCampbell_flc_from_psi(psi, psisat, B, flc) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns unsaturated hydraulic conductivity - ! given water potential and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: psisat !air-entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] -!------------------------------------------------------------------------------ - -flc = (psi/psisat)**(-2._r8-3._r8/B) - -end subroutine unsatkCampbell_flc_from_psi - -!----------------------------------------------------------------------- -subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] -real(r8), intent(in) :: n !pore-size distribution index [-] -real(r8), intent(in) :: m != 1 - 1/n_VG [-] -real(r8), intent(in) :: l !pore tortuosity parameter [-] -real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] -! -! !LOCAL VARIABLES: -real(r8) :: temp !temporary -real(r8) :: fac1a !temporary -real(r8) :: fac1b !temporary -real(r8) :: fac1 !temporary -real(r8) :: fac2 !temporary -real(r8) :: dtemp !temporary -real(r8) :: dfac1adpsi !temporary -real(r8) :: dfac1bdpsi !temporary -real(r8) :: dfac1dpsi !temporary -real(r8) :: dfac2dpsi !temporary -!------------------------------------------------------------------------------ - -temp = ( alpha*abs(psi) ) ** (n) -fac1a = ( alpha*abs(psi) ) ** (n-1._r8) -fac1b = ( 1._r8 + temp ) ** (-1._r8*m) -fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) -fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) - -dtemp = n * alpha * ( alpha*abs(psi) ) ** (n-1._r8) -dfac1adpsi = ( n-1._r8 ) * alpha * ( alpha*abs(psi) ) ** (n-2._r8) -dfac1bdpsi = ( -1._r8 ) * m * dtemp * ( 1._r8 + temp ) ** (-1._r8*m - 1._r8) -dfac1dpsi = ( 2._r8 ) * ( 1._r8 - fac1a*fac1b ) * ( -1._r8*dfac1bdpsi*fac1a - dfac1adpsi*fac1b ) -dfac2dpsi = ( -0.5_r8 ) * m * dtemp * (1._r8 + temp)**(-0.5_r8*m-1._r8) - -dflcdpsi = ( -1._r8 ) * ( dfac2dpsi*fac1 + dfac1dpsi*fac2 ) ! BOC... mult by -1 because unsatk eqn is based on abs(psi) - -end subroutine unsatkVG_dflcdpsi_from_psi - -!----------------------------------------------------------------------- -subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: -real(r8), intent(in) :: psi !soil matric potential [MPa] -real(r8), intent(in) :: psisat !air-entry pressure [MPa] -real(r8), intent(in) :: B !shape parameter [-] -real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] -!------------------------------------------------------------------------------ - -dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) - -end subroutine unsatkCampbell_dflcdpsi_from_psi - - -! ===================================================================================== -! Utility Functions -! ===================================================================================== - -subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS -real(r8) , intent(in) :: a, b ! pft root distribution constants -real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] -real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] -real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] -real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] -real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] -real(r8) , intent(out) :: x_new ! soil depth [m] -! -! !LOCAL VARIABLES: -real(r8) :: lower ! lower bound x estimate [m] -real(r8) :: upper ! upper bound x estimate [m] -real(r8) :: y_lo ! corresponding y value at lower -real(r8) :: f_lo ! y difference between lower bound guess and target y -real(r8) :: y_hi ! corresponding y value at upper -real(r8) :: f_hi ! y difference between upper bound guess and target y -real(r8) :: y_new ! corresponding y value at x.new -real(r8) :: f_new ! y difference between new y guess at x.new and target y -real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) -!---------------------------------------------------------------------- - -lower = lower_init -upper = upper_init -f_lo = zeng2001_crootfr(a, b, lower) - crootfr -f_hi = zeng2001_crootfr(a, b, upper) - crootfr -chg = upper - lower -do while(abs(chg) .gt. xtol) -x_new = 0.5_r8*(lower + upper) -f_new = zeng2001_crootfr(a, b, x_new) - crootfr -if(abs(f_new) .le. ytol) then -EXIT -end if -if((f_lo * f_new) .lt. 0._r8) upper = x_new -if((f_hi * f_new) .lt. 0._r8) lower = x_new -chg = upper - lower -end do -end subroutine bisect_rootfr - -! ===================================================================================== - -function zeng2001_crootfr(a, b, z, z_max) result(crootfr) - - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - real(r8) , intent(in), optional :: z_max ! max soil depth (m) - ! - real(r8) :: crootfr_max - - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) - - - ! If a maximum rooting depth is provided, then - ! we force everything to sum to unity. We do this by - ! simply dividing through by the maximum possible - ! root fraction. - - if(present(z_max))then - crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) - crootfr = crootfr/crootfr_max - end if - - if(debug)then - if(present(z_max))then - if((crootfr_max1.0_r8) )then - write(fates_log(),*) 'problem scaling crootfr in zeng2001' - write(fates_log(),*) 'z_max: ',z_max - write(fates_log(),*) 'crootfr_max: ',crootfr_max - end if - end if - end if - - - return - -end function zeng2001_crootfr - -! ===================================================================================== - -subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: - - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots - ! for the whole site, this layer (m) - real(r8) , intent(in) :: rs1 ! Fine root radius (m) - real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) - real(r8) , intent(in) :: dz ! Width of current soil layer (m) - real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) - real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint - real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) - ! for this layer - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - !----------------------------------------------------------------------- - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshell) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshell > 1) then - do k = 1,nshell-1 - r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshell - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - if(voltype==bcvol)then - do k = 1,nshell - if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) - - else - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo - elseif(voltype==rkvol)then - do k = 1,nshell - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo - end if + !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + + ! This code may be re-introduced at a later date (rgk 08-2019) + + ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP + ! first update the leaf water potential memory + !! do t=2, numLWPmem + !!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) + !!end do + !!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) + !!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + + !!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 + !!do k=1,n_hypool_ag + !!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) + !!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling + !! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & + !! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) + !!end if + !!end do + !!do k=1,n_hypool_troot + !!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) + !!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling + !! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & + !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) + !!end if + !!end do + !!do j=1,site_hydr%nlevsoi_hyd + !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) + !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling + !! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & + !! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) + !!end if + !!end do + !!end subroutine UpdateLWPMemFLCMin -end subroutine shellGeom - -! ===================================================================================== - -function xylemtaper(p, dz) result(chi_tapnotap) - - ! !ARGUMENTS: -real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] -real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] -! -! !LOCAL VARIABLES: -real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) -real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) -! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) -! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. -! Hydraulic trade-offs and space filling enable better predictions of vascular structure -! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. -real(r8) :: lN=0.04_r8 ! petiole length [m] -real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] -real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] -real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] -real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] -real(r8) :: num ! temporary -real(r8) :: den ! temporary -! -! !RESULT -real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz -! -!------------------------------------------------------------------------ - -anotap = 7.19903e-13_r8 -bnotap = 1.326105578_r8 -if (p >= 1.0_r8) then -btap = 2.00586217_r8 -atap = 1.82513E-12_r8 -else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then -btap = 1.854812819_r8 -atap = 6.66908E-13_r8 -else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then -btap = 1.628179741_r8 -atap = 6.58345E-13_r8 -else -btap = bnotap -atap = anotap -end if - -num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) -den = log(little_n) -big_n = num/den - 1._r8 -ktap = atap * (little_n**(big_N* btap/2._r8)) -knotap = anotap * (little_n**(big_N*bnotap/2._r8)) -chi_tapnotap = ktap / knotap - -return - -end function xylemtaper - - - -!! subroutine UpdateLWPMemFLCMin(ccohort_hydr) - -! This code may be re-introduced at a later date (rgk 08-2019) - -! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP -! first update the leaf water potential memory -!! do t=2, numLWPmem -!!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) -!!end do -!!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) -!!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - -!!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 -!!do k=1,n_hypool_ag -!!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) -!!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & -!! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling -!! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & -!! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) -!!end if -!!end do -!!do k=1,n_hypool_troot -!!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) -!!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & -!! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling -!! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & -!! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) -!!end if -!!end do -!!do j=1,site_hydr%nlevsoi_hyd -!!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) -!!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & -!! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling -!! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & -!! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) -!!end if -!!end do -!!end subroutine UpdateLWPMemFLCMin end module FatesPlantHydraulicsMod diff --git a/biogeophys/FatesPlantUnitFunctionsMod.F90 b/biogeophys/FatesPlantUnitFunctionsMod.F90 new file mode 100644 index 0000000000..69bfda5be8 --- /dev/null +++ b/biogeophys/FatesPlantUnitFunctionsMod.F90 @@ -0,0 +1,1899 @@ +module FatesHydroUnitFunctionsMod + + ! This module contains hydraulics functions that are readily broken down into + ! unit tests. These are functions that mostly operate on primitive + ! arguments, are smaller in scope, and are allowed to access the + ! parameter constants EDPftvarcon_inst and params + + use FatesConstants, only : fates_unset_r8 + use EDPftvarcon, only : pft_p => EDPftvarcon_inst + use EDParamsMod , only : hydr_psi0 + use EDParamsMod , only : hydr_psicap + + implicit none + private + + logical, parameter :: debug=.true. + character(len=*), parameter, private :: sourcefile = __FILE__ + + + integer, parameter :: van_genuchten = 1 + integer, parameter :: campbell = 2 + integer, parameter :: iswc = campbell + + + ! P-V curve: total RWC @ which elastic drainage begins [-] + real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) + + ! P-V curve: total RWC @ which capillary reserves exhausted + real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + + ! P-V curve: slope of capillary region of curve + real(r8), allocatable :: cap_slp(:) + + ! P-V curve: intercept of capillary region of curve + real(r8), allocatable :: cap_int(:) + + ! P-V curve: correction for nonzero psi0x + real(r8), allocatable :: cap_corr(:) + + + public :: Hydraulics_Tridiagonal + public :: flc_gs_from_psi + public :: dflcgsdpsi_from_psi + public :: flc_from_psi + public :: dflcdpsi_from_psi + public :: th_from_psi + public :: psi_from_th + public :: dpsidth_from_th + public :: bisect_rootfr + public :: zeng2001_crootfr + public :: shellGeom + public :: xylemtaper + public :: InitAllocatePlantMedia + public :: SetPlantMediaParam + +contains + + + ! ===================================================================================== + + subroutine InitAllocatePlantMedia(n_plant_media) + + ! We only allocate for plant porous media, we do + ! not use these arrays to inform on soil relationships + integer,intent(in) :: n_plant_media + + allocate(rwcft(n_plant_media)) + allocate(rwccap(n_plant_media)) + allocate(cap_slp(n_plant_media)) + allocate(cap_int(n_plant_media)) + allocate(cap_corr(n_plant_media)) + + rwcft(:) = fates_unset_r8 + rwcap(:) = fates_unset_r8 + cap_slp(:) = fates_unset_r8 + cap_int(:) = fates_unset_r8 + cap_corr(:) = fates_unset_r8 + + return + end subroutine InitAllocatePlantMedia + + ! ===================================================================================== + + subroutine SetPlantMediaParam(pm,rwcft_in,rwcap_in) + + ! To avoid complications that would arise from linking this + ! module with the FatesHydraulicsMemMod.F90 during unit tests, we + ! store some of these arrays that are indexed by "porous_media" + ! as globals in this module. + + integer,intent(in) :: pm ! porous media index + real(r8),intent(in) :: rwcft_in ! rwcft for this pm + real(r8),intent(in) :: rwcap_in ! rwcap for this pm + + rwcft(pm) = rwft_in + rwccap(pm) = rwcap_in + + if (pm.eq.1) then ! Leaf tissue + cap_slp(pm) = 0.0_r8 + cap_int(pm) = 0.0_r8 + cap_corr(pm) = 1.0_r8 + else ! Non leaf tissues + cap_slp(pm) = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int(pm) = -cap_slp(pm) + hydr_psi0 + cap_corr(pm) = -cap_int(pm)/cap_slp(pm) + end if + + return + end subroutine SetPlantMediaParam + + ! ===================================================================================== + + subroutine Hydraulics_Tridiagonal(a, b, c, r, u) + ! + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 + ! + ! This solves the form: + ! + ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) + ! + ! It assumed that coefficient a(1) and c(N) DNE as there is + ! no u(0) or u(N-1). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix + real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix + real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix + real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix + real(r8), intent(out) :: u(:) ! solution + ! + ! !LOCAL VARIABLES: + real(r8) :: bet ! temporary + real(r8) :: gam(n_hypool_tot) ! temporary + integer :: k ! index + real(r8) :: err ! solution error, in units of [m3/m3] + real(r8) :: rel_err ! relative error, normalized by delta theta + real(r8), parameter :: allowable_rel_err = 0.001_r8 + ! real(r8), parameter :: allowable_err = 1.e-6_r8 + !---------------------------------------------------------------------- + + bet = b(1) + do k=1,n_hypool_tot + if(k == 1) then + u(k) = r(k) / bet + else + gam(k) = c(k-1) / bet + bet = b(k) - a(k) * gam(k) + u(k) = (r(k) - a(k)*u(k-1)) / bet + end if + enddo + + do k=n_hypool_tot-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) + enddo + + ! If debug mode, calculate error on the forward solution + if(debug)then + do k=1,n_hypool_tot + + if(k==1)then + err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) + elseif(k allowable_rel_err)) then !.and. (err > allowable_err) )then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do + end if + + end subroutine Hydraulics_Tridiagonal + + !===============================================================================! + + function flc_gs_from_psi( lwp, ft ) result( btran ) + + ! + ! !DESCRIPTION: Calculates fractional loss of conductance + ! across the stomata (gs). + + ! + ! !ARGUMENTS + real(r8) , intent(in) :: lwp !leaf water potential (MPa) + integer , intent(in) :: ft + real(r8) :: btran + + btran = & + (1._r8 + & + (lwp/pft_p%hydr_p50_gs(ft))**pft_p%hydr_avuln_gs(ft))**(-1._r8) + + end function flc_gs_from_psi + + !===============================================================================! + + function dflcgsdpsi_from_psi(lwp, ft) result (dflcgsdpsi) + + ! Calculate the derivative of change in fractional loss of conductivity + ! WRT matric potential. + + ! !ARGUMENTS + real(r8), intent(in) :: lwp ! leaf water potential (MPa) + integer , intent(in) :: ft ! leaf pft + + real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] + + + associate(avuln_gs => pft_p%hydr_avuln_gs, & ! Stomatal PLC curve: shape parameter [-] + p50_gs => pft_p%hydr_p50_gs) ! Stomatal PLC curve: water potential + ! at 50% loss of gs,max [Pa] + + + dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(ft))**avuln_gs(ft))**(-2._r8) * & + avuln_gs(ft)/p50_gs(ft)*(lwp/p50_gs(ft))**(avuln_gs(ft)-1._r8) + + end associate + + end function dflcgsdpsi_from_psi + + !===============================================================================! + + function flc_from_psi(ft, pm, psi_node, suc_sat, bsw) result(flc_node) + + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to a fractional loss of conductivity + + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + + real(r8) :: flc_node ! frac loss of conductivity [-] + + associate(& + avuln => pft_p%hydr_avuln_node , & ! PLC curve: vulnerability curve shape parameter [-] + p50 => pft_p%hydr_p50_node & ! PLC curve: water potential at 50% loss of conductivity [Pa] + ) + + if(pm <= 4) then + flc_node = 1._r8/(1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm)) + else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call unsatkVG_flc_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! flc_node) + case (campbell) + call unsatkCampbell_flc_from_psi(psi_node, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw, & + flc_node) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end if + + end associate + + end function flc_from_psi + + !===============================================================================! + + function dflcdpsi_from_psi(ft, pm, psi_node, suc_sat, bsw) result(dflcdpsi_node) + + ! + ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting + ! plant tissue or soil water potentials to a fractional loss of conductivity + + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + real(r8) :: dflcdpsi_node ! deriv fractional loss of conductivity [-] + + associate(& + avuln => pft_p%hydr_avuln_node, & ! vulnerability curve shape parameter [-] + p50 => pft_p%hydr_p50_node & ! water potential at 50% loss of conductivity [Pa] + ) + + if(pm <= 4) then + dflcdpsi_node = -1._r8 * (1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm))**(-2._r8) * & + avuln(ft,pm)/p50(ft,pm)*(psi_node/p50(ft,pm))**(avuln(ft,pm)-1._r8) + else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is ' + write(fates_log(),*) 'inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + !call unsatkVG_dflcdpsi_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! dflcdpsi_node) + case (campbell) + call unsatkCampbell_dflcdpsi_from_psi(psi_node, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw, & + dflcdpsi_node) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic ' + write(fates_log(),*) 'function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end if + + end associate + + end function dflcdpsi_from_psi + + !===============================================================================! + + function th_from_psi(ft, pm, psi_node, th_sat, suc_sat, bsw) result(th_node) + + ! + ! Generic function that calls the correct specific functions for converting + ! plant tissue or soil water potentials to volumetric water contents + + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8), optional,intent(in) :: th_sat ! water content at saturation + ! (porosity for soil) [m3 m-3] + real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + + real(r8) :: th_node ! water content [m3 m-3] + + ! + ! !LOCAL VARIABLES: + real(r8) :: lower ! lower bound of initial estimate [m3 m-3] + real(r8) :: upper ! upper bound of initial estimate [m3 m-3] + real(r8) :: xtol ! error tolerance for x-variable [m3 m-3] + real(r8) :: ytol ! error tolerance for y-variable [MPa] + real(r8) :: satfrac ! soil saturation fraction [0-1] + real(r8) :: psi_check + + + associate(& + thetas => pft_p%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content + resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction + ) + + if(pm <= 4) then + + lower = thetas(ft,pm)*(resid(ft,pm) + 0.0001_r8)/cap_corr(pm) + upper = thetas(ft,pm) + xtol = 1.e-16_r8 + ytol = 1.e-8_r8 + call bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) + psi_check = psi_from_th(ft, pm, th_node) + + if(psi_check > -1.e-8_r8) then + write(fates_log(),*)'bisect_pv returned positive value for water potential at pm = ', char(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + else + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_satfrac_from_psi(psi_node, & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! satfrac) + ! call swcVG_th_from_satfrac(satfrac, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! th_node) + case (campbell) + + call swcCampbell_satfrac_from_psi(psi_node, & + (-1._r8)*suc_sat*denh2o*grav_earth*1.e-9_r8, & + bsw, & + satfrac) + call swcCampbell_th_from_satfrac(satfrac, & + th_sat, & + th_node) + case default + write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end if + + end associate + + end function th_from_psi + + !===============================================================================! + + subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. + ! An analytical solution is not possible because quadratic smoothing functions + ! are used to remove discontinuities in the PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(inout) :: lower ! lower bound of estimate [m3 m-3] + real(r8) , intent(inout) :: upper ! upper bound of estimate [m3 m-3] + real(r8) , intent(in) :: xtol ! error tolerance for x-variable [m3 m-3] + real(r8) , intent(in) :: ytol ! error tolerance for y-variable [MPa] + real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8) , intent(out) :: th_node ! water content [m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: x_new ! new estimate for x in bisection routine + real(r8) :: y_lo ! corresponding y value at lower + real(r8) :: f_lo ! y difference between lower bound guess and target y + real(r8) :: y_hi ! corresponding y value at upper + real(r8) :: f_hi ! y difference between upper bound guess and target y + real(r8) :: y_new ! corresponding y value at x.new + real(r8) :: f_new ! y difference between new y guess at x.new and target y + real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + integer :: nitr ! number of iterations + + if(psi_node > 0.0_r8) then + write(fates_log(),*)'Error: psi_note become positive, psi_node=',psi_node + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + call psi_from_th(ft, pm, lower, y_lo) + call psi_from_th(ft, pm, upper, y_hi) + f_lo = y_lo - psi_node + f_hi = y_hi - psi_node + chg = upper - lower + nitr = 0 + do while(abs(chg) .gt. xtol .and. nitr < 100) + x_new = 0.5_r8*(lower + upper) + call psi_from_th(ft, pm, x_new, y_new) + f_new = y_new - psi_node + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower + nitr = nitr + 1 + end do + + if(nitr .eq. 100)then + write(fates_log(),*)'Warning: number of iteraction reaches 100 for bisect_pv' + endif + + th_node = x_new + + end subroutine bisect_pv + + !===============================================================================! + + function psi_from_th(ft, pm, th_node, th_sat, suc_sat, bsw) result(psi_node) + + ! + ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) + ! at a given water content (th) + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: th_node ! water content [m3 m-3] + real(r8), optional,intent(in) :: th_sat ! water content at saturation + ! (porosity for soil) [m3 m-3] + real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + + ! + ! !LOCAL VARIABLES: + real(r8) :: satfrac ! saturation fraction [0-1] + + ! Result + real(r8) :: psi_node ! water potential [MPa] + + + if(pm <= 4) then ! plant + + call tq2(ft, pm, th_node*cap_corr(pm), psi_node) + + else if(pm == 5) then ! soil + + !! NOTE. FIX: The below sidesteps the problem of averaging potentially variable soil hydraulic properties with depth + !! and simply assigns the bulk soil (bucket) approximation of hydraulic properties as equal to the top soil layer. + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + ! call swcVG_psi_from_th(th_node, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! psi_node) + case (campbell) + call swcCampbell_psi_from_th(th_node,th_sat, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw, & + psi_node) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + end if + + end function psi_from_th + + !===============================================================================! + + function dpsidth_from_th(ft, pm, th_node, th_sat, suc_sat, bsw) result(dpsidth) + ! + ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) + ! at a given water content (th) + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: th_node ! water content [m3 m-3] + real(r8), optional,intent(in) :: th_sat ! water content at saturation + ! (porosity for soil) [m3 m-3] + real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + real(r8) , intent(out) :: dpsidth ! derivative of water potential wrt theta [MPa m3 m-3] + + ! + ! !LOCAL VARIABLES: + + real(r8) :: satfrac ! saturation fraction [0-1] + + + if(pm <= 4) then ! plant + call dtq2dth(ft, pm, th_node*cap_corr(pm), dpsidth) + else if(pm == 5) then ! soil + select case (iswc) + case (van_genuchten) + write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' + call endrun(msg=errMsg(sourcefile, __LINE__)) + !call swcVG_dpsidth_from_th(th_node, & + ! bc_in%watsat_sisl(1), & + ! bc_in%watres_sisl(1), & + ! site_hydr%alpha_VG(1), & + ! site_hydr%n_VG(1), & + ! site_hydr%m_VG(1), & + ! site_hydr%l_VG(1), & + ! y) + case (campbell) + call swcCampbell_dpsidth_from_th(th_node, & + th_sat, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw, & + dpsidth) + case default + write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end if + + end function dpsidth_from_th + + !===============================================================================! + + subroutine tq2(ft, pm, x, y) + ! + ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the + ! plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq2 ! returned y (psi) value from bq2() + real(r8) :: y_cq2 ! returned y (psi) value from cq2() + real(r8) :: beta2=0.99_r8 ! smoothing factor + !---------------------------------------------------------------------- + + call bq2(ft, pm, x, y_bq2) + call cq2(ft, pm, x, y_cq2) + y = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2*beta2) + + end subroutine tq2 + + !===============================================================================! + + subroutine dtq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the + ! plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq2 ! returned y (psi) value from bq2() + real(r8) :: y_cq2 ! returned y (psi) value from cq2() + real(r8) :: dydth_bq2 ! returned derivative from dbq2dth() + real(r8) :: dydth_cq2 ! returned derivative from dcq2dth() + real(r8) :: beta2=0.99_r8 ! smoothing factor + !---------------------------------------------------------------------- + + call bq2(ft, pm, x, y_bq2) + call cq2(ft, pm, x, y_cq2) + call dbq2dth(ft, pm, x, dydth_bq2) + call dcq2dth(ft, pm, x, dydth_cq2) + y = 1._r8/(2._r8*beta2)*(-dydth_bq2 + 0.5_r8*((y_bq2*y_bq2 - 4._r8*beta2*y_cq2)**(-0.5_r8)) * & + (2._r8*y_bq2*dydth_bq2 - 4._r8*beta2*dydth_cq2)) + + end subroutine dtq2dth + + !===============================================================================! + + subroutine bq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + y = -1._r8*(y_tq1 + y_cavitation) + + end subroutine bq2 + + !===============================================================================! + + subroutine dbq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() + real(r8) :: dcavdth ! returned derivative from dcavitationdth() + !---------------------------------------------------------------------- + + call dtq1dth(ft, pm, x, dydth_tq1) + call dcavitationPVdth(ft, pm, x, dcavdth) + y = -1._r8*(dydth_tq1 + dcavdth) + + end subroutine dbq2dth + + !===============================================================================! + + subroutine cq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + y = y_tq1*y_cavitation + + end subroutine cq2 + + !===============================================================================! + + subroutine dcq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq2() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() + real(r8) :: dcavdth ! returned derivative from dcavitationdth() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + call dtq1dth(ft, pm, x, dydth_tq1) + call dcavitationPVdth(ft, pm, x, dcavdth) + y = y_tq1*dcavdth + dydth_tq1*y_cavitation + + end subroutine dcq2dth + + !===============================================================================! + + subroutine tq1(ft, pm, x, y) + ! + ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or + ! does a smoothing function for capillary-to-elastic region of the plant PV + ! curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq1 ! returned y (psi) value from bq1() + real(r8) :: y_cq1 ! returned y (psi) value from cq1() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + real(r8) :: beta1=0.80_r8 ! smoothing factor + !---------------------------------------------------------------------- + + if(pm == 1) then ! leaves have no capillary region in their PV curves + call elasticPV(ft, pm, x, y_elastic) + y = y_elastic + else if(pm <= 4) then ! sapwood has a capillary region + call bq1(ft, pm, x, y_bq1) + call cq1(ft, pm, x, y_cq1) + y = (-y_bq1 - sqrt(y_bq1*y_bq1 - 4._r8*beta1*y_cq1))/(2*beta1) + end if !porous media + + end subroutine tq1 + + !===============================================================================! + + subroutine dtq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of tq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq1 ! returned y (psi) value from bq1() + real(r8) :: y_cq1 ! returned y (psi) value from cq1() + real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() + real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + real(r8) :: beta1=0.80_r8 ! smoothing factor + !---------------------------------------------------------------------- + + if(pm == 1) then ! leaves have no capillary region in their PV curves + call delasticPVdth(ft, pm, x, delasticdth) + y = delasticdth + else if(pm <= 4) then ! sapwood has a capillary region + call bq1(ft, pm, x, y_bq1) + call cq1(ft, pm, x, y_cq1) + call dbq1dth(ft, pm, x, dydth_bq1) + call dcq1dth(ft, pm, x, dydth_cq1) + y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & + (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) + end if + + end subroutine dtq1dth + + !===============================================================================! + + subroutine bq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + y = -1._r8*(y_capillary + y_elastic) + + end subroutine bq1 + + !===============================================================================! + + subroutine dbq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of bq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + !---------------------------------------------------------------------- + + call dcapillaryPVdth(ft, pm, x, dcapdth) + call delasticPVdth(ft, pm, x, delasticdth) + y = -1._r8*(delasticdth + dcapdth) + + end subroutine dbq1dth + + !===============================================================================! + + subroutine cq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + y = y_capillary*y_elastic + + end subroutine cq1 + + !===============================================================================! + + subroutine dcq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + call dcapillaryPVdth(ft, pm, x, dcapdth) + call delasticPVdth(ft, pm, x, delasticdth) + y = y_elastic*dcapdth + delasticdth*y_capillary + + end subroutine dcq1dth + + !===============================================================================! + + subroutine cavitationPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_solute ! returned y (psi) value from solutepsi() + !---------------------------------------------------------------------- + + call solutepsi(ft, pm, x, y_solute) + y = y_solute + + end subroutine cavitationPV + + !===============================================================================! + + subroutine dcavitationPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dsoldth ! returned derivative from dsolutepsidth() + !---------------------------------------------------------------------- + + call dsolutepsidth(ft, pm, x, dsoldth) + y = dsoldth + + end subroutine dcavitationPVdth + + !===============================================================================! + + subroutine elasticPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_solute ! returned y (psi) value from solutepsi() + real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() + !---------------------------------------------------------------------- + + call solutepsi(ft, pm, x, y_solute) + call pressurepsi(ft, pm, x, y_pressure) + y = y_solute + y_pressure + + end subroutine elasticPV + + !===============================================================================! + + subroutine delasticPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of elasticPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dsoldth ! returned derivative from dsolutepsidth() + real(r8) :: dpressdth ! returned derivative from dpressurepsidth() + !---------------------------------------------------------------------- + + call dsolutepsidth(ft, pm, x, dsoldth) + call dpressurepsidth(ft, pm, x, dpressdth) + y = dsoldth + dpressdth + + end subroutine delasticPVdth + + !===============================================================================! + + subroutine solutepsi(ft, pm, x, y) + ! + ! !DESCRIPTION: computes solute water potential (negative) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + pinot => pft_p%hydr_pinot_node, & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] + thetas => pft_p%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + ) + + y = pinot(ft,pm)*thetas(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & + (x - thetas(ft,pm)*resid(ft,pm)) + + end associate + + end subroutine solutepsi + + !===============================================================================! + + subroutine dsolutepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of solutepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + pinot => pft_p%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] + thetas => pft_p%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + ) + + y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & + ((x - thetas(ft,pm)*resid(ft,pm))**2._r8) + + end associate + end subroutine dsolutepsidth + + !===============================================================================! + + subroutine pressurepsi(ft, pm, x, y) + ! + ! !DESCRIPTION: computes pressure water potential (positive) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + pinot => pft_p%hydr_pinot_node , & ! P-V curve: osmotic potential at full turgor [MPa] + thetas => pft_p%hydr_thetas_node , & ! P-V curve: saturated volumetric water content for node [m3 m-3] + resid => pft_p%hydr_resid_node , & ! P-V curve: residual fraction [-] + epsil => pft_p%hydr_epsil_node & ! P-V curve: bulk elastic modulus [MPa] + ) + + y = epsil(ft,pm) * (x - thetas(ft,pm)*rwcft(pm)) / & + (thetas(ft,pm)*(rwcft(pm)-resid(ft,pm))) - pinot(ft,pm) + + end associate + end subroutine pressurepsi + + !===============================================================================! + + subroutine dpressurepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => pft_p%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => pft_p%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + epsil => pft_p%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] + ) + + y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) + + end associate + + end subroutine dpressurepsidth + + !===============================================================================! + + subroutine capillaryPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the capillary region of the plant + ! PV curve (sapwood only) + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => pft_p%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + ) + + y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x + + end associate + end subroutine capillaryPV + + !===============================================================================! + + subroutine dcapillaryPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => pft_p%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + ) + + y = cap_slp(pm)/thetas(ft,pm) + + end associate + + end subroutine dcapillaryPVdth + + !===============================================================================! + + subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns saturation fraction given water content, porosity, and residual water content + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] + real(r8), intent(out) :: satfrac !saturation fraction [0-1] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + satfrac = (th - watres)/(watsat - watres) + + end subroutine swcVG_satfrac_from_th + + !===============================================================================! + + subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns saturation fraction given water content and porosity + ! + !USES + !ARGUMENTS: + real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(out) :: satfrac !saturation fraction [0-1] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + satfrac = th/watsat + + end subroutine swcCampbell_satfrac_from_th + + !===============================================================================! + + subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns water potential given water content and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: th !volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: psi !soil matric potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: satfrac !saturation fraction [0-1] + !------------------------------------------------------------------------------ + + call swcVG_satfrac_from_th(th, watsat, watres, satfrac) + call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) + + end subroutine swcVG_psi_from_th + + !===============================================================================! + + subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns water potential given saturation fraction, air-entry pressure and shape parameter + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: th !volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: psisat !air entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: psi !soil matric potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: satfrac !saturation fraction [0-1] + !------------------------------------------------------------------------------ + + call swcCampbell_satfrac_from_th(th, watsat, satfrac) + call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) + + end subroutine swcCampbell_psi_from_th + + !===============================================================================! + + subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns water potential given saturation fraction and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: psi !soil matric potential [MPa] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) + + end subroutine swcVG_psi_from_satfrac + + !===============================================================================! + + subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns water potential given saturation fraction, air-entry pressure and shape parameter + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: psisat !air entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: psi !soil matric potential [MPa] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + psi = psisat*(satfrac**(-B)) + + end subroutine swcCampbell_psi_from_satfrac + + !===============================================================================! + + subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns water content given saturation fraction, porosity and residual water content + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] + real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + th = watres + satfrac*(watsat - watres) + + end subroutine swcVG_th_from_satfrac + + !===============================================================================! + + subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns water content given saturation fraction and porosity + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + th = satfrac*watsat + + end subroutine swcCampbell_th_from_satfrac + + !======================================================================- + subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns saturation fraction given water potential and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m + + end subroutine swcVG_satfrac_from_psi + + !======================================================================- + subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns saturation fraction given water potential and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: psisat !air-entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] + ! + ! !LOCAL VARIABLES: + !------------------------------------------------------------------------------ + + satfrac = (psi/psisat)**(-1.0_r8/B) + + end subroutine swcCampbell_satfrac_from_psi + + !======================================================================- + subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given water content and SWC parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: th !volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: satfrac !saturation fraction [0-1] + !------------------------------------------------------------------------------ + + call swcVG_satfrac_from_th(th, watsat, watres, satfrac) + call swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) + + end subroutine swcVG_dpsidth_from_th + + !======================================================================- + subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given water content and SWC parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: th !volumetric water content [m3 m-3] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: psisat !air entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: satfrac !saturation fraction [0-1] + !------------------------------------------------------------------------------ + + call swcCampbell_satfrac_from_th(th, watsat, satfrac) + call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) + + end subroutine swcCampbell_dpsidth_from_th + + !======================================================================- + subroutine swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given saturation fraction and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: temp0 !temporary + real(r8) :: temp1 !temporary + real(r8) :: temp2 !temporary + real(r8) :: temp3 !temporary + !------------------------------------------------------------------------------ + + temp0 = 1._r8/(m*n*alpha*(watsat-watres)) + temp1 = satfrac**(-1._r8/m) - 1._r8 + temp2 = temp1**(1._r8/n - 1._r8) + temp3 = satfrac**(-1._r8/m - 1._r8) + dpsidth = temp0*temp2*temp3 + + end subroutine swcVG_dpsidth_from_satfrac + + !======================================================================- + subroutine swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given saturation fraction and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: satfrac !saturation fraction [0-1] + real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] + real(r8), intent(in) :: psisat !air-entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] + !------------------------------------------------------------------------------ + + dpsidth = psisat*(-B)/watsat*(satfrac)**(-B-1._r8) + + end subroutine swcCampbell_dpsidth_from_satfrac + + !======================================================================- + subroutine unsatkVG_flc_from_psi(psi, alpha, n, m, l, flc) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns unsaturated hydraulic conductivity + ! given water potential and SWC parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] + ! + ! !LOCAL VARIABLES: + real(r8) :: temp !temporary + real(r8) :: fac1a !temporary + real(r8) :: fac1b !temporary + real(r8) :: fac1 !temporary + real(r8) :: fac2 !temporary + !------------------------------------------------------------------------------ + + temp = ( alpha*abs(psi) ) ** (n) + fac1a = ( alpha*abs(psi) ) ** (n-1._r8) + fac1b = ( 1._r8 + temp ) ** (-1._r8*m) + fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) + fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) + + flc = fac1 * fac2 + + end subroutine unsatkVG_flc_from_psi + + !======================================================================- + + subroutine unsatkCampbell_flc_from_psi(psi, psisat, B, flc) + ! + ! DESCRIPTION + ! Campbell (1974) soil water characteristic (retention) curve + ! returns unsaturated hydraulic conductivity + ! given water potential and SWC parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: psisat !air-entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: flc !k/ksat ('fractional loss of conductivity') [-] + !------------------------------------------------------------------------------ + + flc = (psi/psisat)**(-2._r8-3._r8/B) + + end subroutine unsatkCampbell_flc_from_psi + + !======================================================================- + subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given saturation fraction and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n !pore-size distribution index [-] + real(r8), intent(in) :: m != 1 - 1/n_VG [-] + real(r8), intent(in) :: l !pore tortuosity parameter [-] + real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] + ! + ! !LOCAL VARIABLES: + real(r8) :: temp !temporary + real(r8) :: fac1a !temporary + real(r8) :: fac1b !temporary + real(r8) :: fac1 !temporary + real(r8) :: fac2 !temporary + real(r8) :: dtemp !temporary + real(r8) :: dfac1adpsi !temporary + real(r8) :: dfac1bdpsi !temporary + real(r8) :: dfac1dpsi !temporary + real(r8) :: dfac2dpsi !temporary + !------------------------------------------------------------------------------ + + temp = ( alpha*abs(psi) ) ** (n) + fac1a = ( alpha*abs(psi) ) ** (n-1._r8) + fac1b = ( 1._r8 + temp ) ** (-1._r8*m) + fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) + fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) + + dtemp = n * alpha * ( alpha*abs(psi) ) ** (n-1._r8) + dfac1adpsi = ( n-1._r8 ) * alpha * ( alpha*abs(psi) ) ** (n-2._r8) + dfac1bdpsi = ( -1._r8 ) * m * dtemp * ( 1._r8 + temp ) ** (-1._r8*m - 1._r8) + dfac1dpsi = ( 2._r8 ) * ( 1._r8 - fac1a*fac1b ) * ( -1._r8*dfac1bdpsi*fac1a - dfac1adpsi*fac1b ) + dfac2dpsi = ( -0.5_r8 ) * m * dtemp * (1._r8 + temp)**(-0.5_r8*m-1._r8) + + dflcdpsi = ( -1._r8 ) * ( dfac2dpsi*fac1 + dfac1dpsi*fac2 ) ! BOC... mult by -1 because unsatk eqn is based on abs(psi) + + end subroutine unsatkVG_dflcdpsi_from_psi + + !======================================================================- + subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) + ! + ! DESCRIPTION + ! van Genuchten (1980) soil water characteristic (retention) curve + ! returns derivative of water water potential with respect to water content + ! given saturation fraction and shape parameters + ! + !USES + ! + ! !ARGUMENTS: + real(r8), intent(in) :: psi !soil matric potential [MPa] + real(r8), intent(in) :: psisat !air-entry pressure [MPa] + real(r8), intent(in) :: B !shape parameter [-] + real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] + !------------------------------------------------------------------------------ + + dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) + + end subroutine unsatkCampbell_dflcdpsi_from_psi + + + ! ===================================================================================== + ! Utility Functions + ! ===================================================================================== + + subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] + real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] + real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] + real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] + real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] + real(r8) , intent(out) :: x_new ! soil depth [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: lower ! lower bound x estimate [m] + real(r8) :: upper ! upper bound x estimate [m] + real(r8) :: y_lo ! corresponding y value at lower + real(r8) :: f_lo ! y difference between lower bound guess and target y + real(r8) :: y_hi ! corresponding y value at upper + real(r8) :: f_hi ! y difference between upper bound guess and target y + real(r8) :: y_new ! corresponding y value at x.new + real(r8) :: f_new ! y difference between new y guess at x.new and target y + real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + !---------------------------------------------------------------------- + + lower = lower_init + upper = upper_init + f_lo = zeng2001_crootfr(a, b, lower) - crootfr + f_hi = zeng2001_crootfr(a, b, upper) - crootfr + chg = upper - lower + do while(abs(chg) .gt. xtol) + x_new = 0.5_r8*(lower + upper) + f_new = zeng2001_crootfr(a, b, x_new) - crootfr + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower + end do + end subroutine bisect_rootfr + + ! ===================================================================================== + + function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: + real(r8) , intent(in) :: a,b ! pft parameters + real(r8) , intent(in) :: z ! soil depth (m) + real(r8) , intent(in), optional :: z_max ! max soil depth (m) + ! + real(r8) :: crootfr_max + + ! !RESULT + real(r8) :: crootfr ! cumulative root fraction + ! + !------------------------------------------------------------------------ + crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + + + ! If a maximum rooting depth is provided, then + ! we force everything to sum to unity. We do this by + ! simply dividing through by the maximum possible + ! root fraction. + + if(present(z_max))then + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max + end if + + if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max + end if + end if + end if + + + return + + end function zeng2001_crootfr + + ! ===================================================================================== + + subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: + + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots + ! for the whole site, this layer (m) + real(r8) , intent(in) :: rs1 ! Fine root radius (m) + real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) + real(r8) , intent(in) :: dz ! Width of current soil layer (m) + real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) + real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint + real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) + ! for this layer + ! + ! !LOCAL VARIABLES: + integer :: k ! rhizosphere shell indicies + !----------------------------------------------------------------------- + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + r_out_shell(nshell) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshell > 1) then + do k = 1,nshell-1 + r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 + enddo + end if + + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + + do k = 2,nshell + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo + + ! update volumes + if(voltype==bcvol)then + do k = 1,nshell + if(k == 1) then + ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level + v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) + + else + v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + elseif(voltype==rkvol)then + do k = 1,nshell + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + end if + + end subroutine shellGeom + + ! ===================================================================================== + + function xylemtaper(p, dz) result(chi_tapnotap) + + ! !ARGUMENTS: + real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] + real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) + real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) + ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) + ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. + ! Hydraulic trade-offs and space filling enable better predictions of vascular structure + ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. + real(r8) :: lN=0.04_r8 ! petiole length [m] + real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] + real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] + real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: num ! temporary + real(r8) :: den ! temporary + ! + ! !RESULT + real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz + ! + !------------------------------------------------------------------------ + + anotap = 7.19903e-13_r8 + bnotap = 1.326105578_r8 + if (p >= 1.0_r8) then + btap = 2.00586217_r8 + atap = 1.82513E-12_r8 + else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then + btap = 1.854812819_r8 + atap = 6.66908E-13_r8 + else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then + btap = 1.628179741_r8 + atap = 6.58345E-13_r8 + else + btap = bnotap + atap = anotap + end if + + num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) + den = log(little_n) + big_n = num/den - 1._r8 + ktap = atap * (little_n**(big_N* btap/2._r8)) + knotap = anotap * (little_n**(big_N*bnotap/2._r8)) + chi_tapnotap = ktap / knotap + + return + + end function xylemtaper + + +end module FatesHydroUnitFunctionsMod diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9028f63c62..64fc457eaa 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -3,8 +3,7 @@ module FatesHydraulicsMemMod use FatesConstantsMod, only : r8 => fates_r8 use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use FatesConstantsMod, only : itrue,ifalse - use EDParamsMod , only : hydr_psi0 - use EDParamsMod , only : hydr_psicap + implicit none private @@ -68,23 +67,10 @@ module FatesHydraulicsMemMod ! Carbon 2 biomass ratio real(r8), parameter, public :: C2B = 2.0_r8 - ! P-V curve: total RWC @ which elastic drainage begins [-] - real(r8), parameter, public, dimension(n_porous_media) :: rwcft = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) - - ! P-V curve: total RWC @ which capillary reserves exhausted - real(r8), parameter, public, dimension(n_porous_media) :: rwccap = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + ! Derived parameters ! ---------------------------------------------------------------------------------------------- - - ! P-V curve: slope of capillary region of curve - real(r8), public, dimension(n_porous_media) :: cap_slp - - ! P-V curve: intercept of capillary region of curve - real(r8), public, dimension(n_porous_media) :: cap_int - - ! P-V curve: correction for nonzero psi0x - real(r8), public, dimension(n_porous_media) :: cap_corr !temporatory variables real(r8), public :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a @@ -399,41 +385,5 @@ subroutine InitHydrSite(this) return end subroutine InitHydrSite - ! =================================================================================== - - subroutine InitHydraulicsDerived(numpft) - - !use EDPftvarcon, only : EDPftvarcon_inst - ! Arguments - integer,intent(in) :: numpft - - integer :: k ! Pool counting index - integer :: ft - - do k = 1,n_porous_media - - if (k.eq.1) then ! Leaf tissue - cap_slp(k) = 0.0_r8 - cap_int(k) = 0.0_r8 - cap_corr(k) = 1.0_r8 - else ! Non leaf tissues - cap_slp(k) = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(k)) - cap_int(k) = -cap_slp(k) + hydr_psi0 - cap_corr(k) = -cap_int(k)/cap_slp(k) - end if - end do - - do ft=1,numpft - ! this needs a -999 check (BOC) - !EDPftvarcon_inst%hydr_pinot_node(ft,:) = EDPftvarcon_inst%hydr_pitlp_node(ft,:) * & - ! EDPftvarcon_inst%hydr_epsil_node(ft,:) / & - ! (EDPftvarcon_inst%hydr_epsil_node(ft,:) - & - ! EDPftvarcon_inst%hydr_pitlp_node(ft,:)) - end do - - return - end subroutine InitHydraulicsDerived - - end module FatesHydraulicsMemMod From 0363e166b12f907aee99af00afc5177bd02d91e8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 13 Sep 2019 14:10:28 -0700 Subject: [PATCH 023/114] Hydro unit test stuff --- ...Mod.F90 => FatesHydroUnitFunctionsMod.F90} | 97 ++++-- biogeophys/FatesPlantHydraulicsMod.F90 | 9 +- .../shared/f90_src/UnitWrapMod.F90_in | 214 +++++++++++++ .../shared/py_src/CDLParse.py | 292 ++++++++++++++++++ .../shared/py_src/F90ParamParse.py | 159 ++++++++++ .../shared/py_src/PyF90Utils.py | 17 + 6 files changed, 747 insertions(+), 41 deletions(-) rename biogeophys/{FatesPlantUnitFunctionsMod.F90 => FatesHydroUnitFunctionsMod.F90} (96%) create mode 100644 functional_unit_testing/shared/f90_src/UnitWrapMod.F90_in create mode 100644 functional_unit_testing/shared/py_src/CDLParse.py create mode 100644 functional_unit_testing/shared/py_src/F90ParamParse.py create mode 100644 functional_unit_testing/shared/py_src/PyF90Utils.py diff --git a/biogeophys/FatesPlantUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 similarity index 96% rename from biogeophys/FatesPlantUnitFunctionsMod.F90 rename to biogeophys/FatesHydroUnitFunctionsMod.F90 index 69bfda5be8..04923bd744 100644 --- a/biogeophys/FatesPlantUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -5,17 +5,37 @@ module FatesHydroUnitFunctionsMod ! arguments, are smaller in scope, and are allowed to access the ! parameter constants EDPftvarcon_inst and params - use FatesConstants, only : fates_unset_r8 - use EDPftvarcon, only : pft_p => EDPftvarcon_inst - use EDParamsMod , only : hydr_psi0 - use EDParamsMod , only : hydr_psicap - + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : pa_per_mpa + use FatesConstantsMod, only : mpa_per_pa + use FatesConstantsMod, only : mm_per_m + use FatesConstantsMod, only : m_per_mm + use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water + use FatesConstantsMod, only : grav_earth + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : pi_const + use EDPftvarcon, only : pft_p => EDPftvarcon_inst + use EDParamsMod, only : hydr_psi0 + use EDParamsMod, only : hydr_psicap + use FatesGlobals, only : fates_log + use FatesGlobals, only : endrun => fates_endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private logical, parameter :: debug=.true. character(len=*), parameter, private :: sourcefile = __FILE__ + ! Currently testing two different ways to represent rhizosphere shell + ! volumes. The old way used a "representative" shell volume, the + ! new way is an absolute volume, in total cubic meters over the + ! whole hectare. + + integer, parameter :: bcvol = 1 + integer, parameter :: rkvol = 2 + integer, parameter :: voltype = rkvol integer, parameter :: van_genuchten = 1 integer, parameter :: campbell = 2 @@ -70,10 +90,10 @@ subroutine InitAllocatePlantMedia(n_plant_media) allocate(cap_int(n_plant_media)) allocate(cap_corr(n_plant_media)) - rwcft(:) = fates_unset_r8 - rwcap(:) = fates_unset_r8 - cap_slp(:) = fates_unset_r8 - cap_int(:) = fates_unset_r8 + rwcft(:) = fates_unset_r8 + rwccap(:) = fates_unset_r8 + cap_slp(:) = fates_unset_r8 + cap_int(:) = fates_unset_r8 cap_corr(:) = fates_unset_r8 return @@ -81,7 +101,7 @@ end subroutine InitAllocatePlantMedia ! ===================================================================================== - subroutine SetPlantMediaParam(pm,rwcft_in,rwcap_in) + subroutine SetPlantMediaParam(pm,rwcft_in,rwccap_in) ! To avoid complications that would arise from linking this ! module with the FatesHydraulicsMemMod.F90 during unit tests, we @@ -90,10 +110,10 @@ subroutine SetPlantMediaParam(pm,rwcft_in,rwcap_in) integer,intent(in) :: pm ! porous media index real(r8),intent(in) :: rwcft_in ! rwcft for this pm - real(r8),intent(in) :: rwcap_in ! rwcap for this pm + real(r8),intent(in) :: rwccap_in ! rwcap for this pm - rwcft(pm) = rwft_in - rwccap(pm) = rwcap_in + rwcft(pm) = rwcft_in + rwccap(pm) = rwccap_in if (pm.eq.1) then ! Leaf tissue cap_slp(pm) = 0.0_r8 @@ -132,16 +152,18 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) ! ! !LOCAL VARIABLES: real(r8) :: bet ! temporary - real(r8) :: gam(n_hypool_tot) ! temporary + real(r8) :: gam(10) ! temporary integer :: k ! index + integer :: N ! Size of the matrix real(r8) :: err ! solution error, in units of [m3/m3] real(r8) :: rel_err ! relative error, normalized by delta theta - real(r8), parameter :: allowable_rel_err = 0.001_r8 + real(r8), parameter :: allowable_rel_err = 0.0001_r8 + ! real(r8), parameter :: allowable_err = 1.e-6_r8 !---------------------------------------------------------------------- - + N=size(r,dim=1) bet = b(1) - do k=1,n_hypool_tot + do k=1,N if(k == 1) then u(k) = r(k) / bet else @@ -151,17 +173,17 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) end if enddo - do k=n_hypool_tot-1,1,-1 + do k=N-1,1,-1 u(k) = u(k) - gam(k+1) * u(k+1) enddo ! If debug mode, calculate error on the forward solution if(debug)then - do k=1,n_hypool_tot + do k=1,N if(k==1)then err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) - elseif(k 1) then - do k = 1,nshell-1 - r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 + r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 enddo end if @@ -1813,13 +1844,13 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - do k = 2,nshell + do k = 2,nshells r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) enddo ! update volumes if(voltype==bcvol)then - do k = 1,nshell + do k = 1,nshells if(k == 1) then ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) @@ -1829,7 +1860,7 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s end if enddo elseif(voltype==rkvol)then - do k = 1,nshell + do k = 1,nshells if(k == 1) then v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) else diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ca577f5def..bd25c39954 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -120,14 +120,7 @@ module FatesPlantHydraulicsMod - ! Currently testing two different ways to represent rhizosphere shell - ! volumes. The old way used a "representative" shell volume, the - ! new way is an absolute volume, in total cubic meters over the - ! whole hectare. - - integer, parameter :: bcvol = 1 - integer, parameter :: rkvol = 2 - integer, parameter :: voltype = rkvol + ! 1=leaf, 2=stem, 3=troot, 4=aroot ! Several of these may be better transferred to the parameter file in due time (RGK) diff --git a/functional_unit_testing/shared/f90_src/UnitWrapMod.F90_in b/functional_unit_testing/shared/f90_src/UnitWrapMod.F90_in new file mode 100644 index 0000000000..7bb2d5b67f --- /dev/null +++ b/functional_unit_testing/shared/f90_src/UnitWrapMod.F90_in @@ -0,0 +1,214 @@ + +! ======================================================================================= +! +! This file is an alternative to key files in the fates +! filesystem. Noteably, we replace fates_r8 and fates_in +! with types that work with "ctypes". This is +! a key step in working with python +! +! We also wrap FatesGlobals to reduce the dependancy +! cascade that it pulls in from shr_log_mod. +! +! ======================================================================================= + +module shr_log_mod + + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + + contains + + function shr_log_errMsg(source, line) result(ans) + character(kind=c_char,len=*), intent(in) :: source + integer(c_int), intent(in) :: line + character(kind=c_char,len=128) :: ans + + ans = "source: " // trim(source) // " line: " + end function shr_log_errMsg + +end module shr_log_mod + + +module FatesGlobals + + contains + + integer function fates_log() + fates_log = -1 + end function fates_log + + subroutine fates_endrun(msg) + + implicit none + character(len=*), intent(in) :: msg ! string to be printed + + stop + + end subroutine fates_endrun + +end module FatesGlobals + + +module EDTypesMod + + use iso_c_binding, only : r8 => c_double + + integer, parameter :: nclmax = 2 + integer, parameter :: nlevleaf = 30 + real(r8), parameter :: dinc_ed = 1.0_r8 + +end module EDTypesMod + + +module EDPftvarcon + + use iso_c_binding, only : r8 => c_double + use iso_c_binding, only : i4 => c_int + use iso_c_binding, only : c_char + + integer,parameter :: SHR_KIND_CS = 80 ! short char + + type, public :: EDPftvarcon_inst_type + + ! VARIABLE-DEFINITIONS-HERE (DO NOT REMOVE THIS LINE, OR MOVE IT) + + real(r8),pointer :: parteh_mode(:) + + end type EDPftvarcon_inst_type + + type ptr_var1 + real(r8), dimension(:), pointer :: var_rp + integer(i4), dimension(:), pointer :: var_ip + character(len=shr_kind_cs) :: var_name + integer :: vtype + end type ptr_var1 + + type ptr_var2 + real(r8), dimension(:,:), pointer :: var_rp + integer(i4), dimension(:,:), pointer :: var_ip + character(len=shr_kind_cs) :: var_name + integer :: vtype + end type ptr_var2 + + type EDPftvarcon_ptr_type + type(ptr_var1), allocatable :: var1d(:) + type(ptr_var2), allocatable :: var2d(:) + end type EDPftvarcon_ptr_type + + + type(EDPftvarcon_inst_type), public :: EDPftvarcon_inst ! ED ecophysiological constants structure + type(EDPftvarcon_ptr_type), public :: EDPftvarcon_ptr ! Pointer structure for obj-oriented id + + integer :: numparm1d ! Number of different PFT parameters + integer :: numparm2d + integer :: numpft + logical, parameter :: debug = .true. + +contains + + + subroutine EDPftvarconPySet(rval,ival,indx1,indx2,name) + + implicit none + ! Arguments + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + integer(i4),intent(in) :: ival + integer(i4),intent(in) :: indx1 + integer(i4),intent(in) :: indx2 + ! Locals + logical :: npfound + integer :: ip + integer :: namelen + + namelen = len(trim(name)) + + if(debug) print*,"F90: ARGS: ",trim(name)," IPFT: ",indx1," D2: ",indx2," RVAL: ",rval," IVAL: ",ival + + ip=0 + npfound = .false. + do ip=1,numparm1d + + if (trim(name) == trim(EDPftvarcon_ptr%var1d(ip)%var_name ) ) then + print*,"F90: Found ",trim(name)," in lookup table" + npfound = .true. + if(EDPftvarcon_ptr%var1d(ip)%vtype == 1) then ! real + EDPftvarcon_ptr%var1d(ip)%var_rp(indx1) = rval + elseif(EDPftvarcon_ptr%var1d(ip)%vtype == 2) then ! integer + EDPftvarcon_ptr%var1d(ip)%var_ip(indx1) = ival + else + print*,"F90: STRANGE TYPE" + stop + end if + end if + end do + + do ip=1,numparm2d + if (trim(name) == trim(EDPftvarcon_ptr%var2d(ip)%var_name ) ) then + print*,"F90: Found ",trim(name)," in lookup table" + npfound = .true. + if(EDPftvarcon_ptr%var2d(ip)%vtype == 1) then ! real + EDPftvarcon_ptr%var2d(ip)%var_rp(indx1,indx2) = rval + elseif(EDPftvarcon_ptr%var2d(ip)%vtype == 2) then ! integer + EDPftvarcon_ptr%var2d(ip)%var_ip(indx1,indx2) = ival + else + print*,"F90: STRANGE TYPE" + stop + end if + end if + end do + + + + if(.not.npfound)then + print*,"F90: The parameter you loaded DNE: ",name(:) + stop + end if + + + return + end subroutine EDPftvarconPySet + + + subroutine EDPftvarconAlloc(ARGUMENT_IN1) + ! + use FatesConstantsMod, only : fates_unset_r8 + + implicit none + + ! ARGUMENT_DEF1 + + + ! LOCALS: + integer :: iv1 ! The parameter incrementer + integer :: iv2 + !------------------------------------------------------------------------ + + allocate( EDPftvarcon_ptr%var1d(100)) ! Make this plenty large + allocate( EDPftvarcon_ptr%var2d(100)) + iv1=0 + iv2=0 + + ! POINTER-SPECIFICATION-HERE (DO NOT REMOVE THIS LINE, OR MOVE IT) + + allocate( EDPftvarcon_inst%parteh_mode (fates_pft)); + EDPftvarcon_inst%parteh_mode (:) = fates_unset_r8 + iv1 = iv1 + 1 + EDPftvarcon_ptr%var1d(iv1)%var_name = "fates_parteh_mode" + EDPftvarcon_ptr%var1d(iv1)%var_rp => EDPftvarcon_inst%parteh_mode + EDPftvarcon_ptr%var1d(iv1)%vtype = 1 + + + numparm1d = iv1 + numparm2d = iv2 + + print*,"F90: ALLOCATED ",numparm1d," 1D PARAMETERS" + print*,"F90: ALLOCATED ",numparm2d," 2D PARAMETERS" + print*,"FOR ",fates_pft," PFTs" + + numpft = fates_pft + + return + end subroutine EDPftvarconAlloc + +end module EDPftvarcon \ No newline at end of file diff --git a/functional_unit_testing/shared/py_src/CDLParse.py b/functional_unit_testing/shared/py_src/CDLParse.py new file mode 100644 index 0000000000..32bc2fff44 --- /dev/null +++ b/functional_unit_testing/shared/py_src/CDLParse.py @@ -0,0 +1,292 @@ + +# ======================================================================================= +# This will look through a CDL file for the provided parameter and determine +# the parameter's type, as well as fill an array with the data +# ======================================================================================= + +import re # This is a heftier string parser +import code # For development: code.interact(local=dict(globals(), **locals())) +import numpy as np + +# Global identifiers for the type of data +# --------------------------------------------------------------------------------------- + +char_type = 0 +int_type = 1 +float_type = 2 +double_type = 3 + +# If we encounter a "_", ie no data? +no_data_fill='1.e-32' + + +# This is base object for a parameter +# =================================== +class cdl_param_type: + + def __init__(self,symbol): + + self.datatype = -9 + self.dim_namelist = [] + self.dim_sizelist = [] + self.ndims = -9 + self.symbol = symbol + self.units = 'NA' + + def Add1DToXD(self,val,indx): + + if(self.ndims==0): + self.data[indx] = val + + elif(self.ndims==1): + n1 = self.dim_sizelist[0] + if((indx<0) or (indx>=n1)): + print('Problem in CDLParse filling data array') + print('index must be between {} {}, value = {}'.format(0,n1,indx)) + print('param: {}'.format(self.symbol)) + exit(2) + else: + self.data[indx] = val + + elif(self.ndims==2): + n1 = self.dim_sizelist[0] + n2 = self.dim_sizelist[1] + i2 = np.mod(indx+1,n2) + i1 = int(indx/n2) + self.data[i1,i2] = val + + else: + print('No more than 2 dimensions can be processed by Add1dToXd()') + exit(2) + + + +# This routine adds a new parameter to the list of cdl_param_types +# ================================================================ +def CDLParseParam(file_name,param,dim_dic): + + fp = open(file_name,"r") + contents = fp.readlines() + fp.close() + + # Look in the file for the definition for the parameter + # of interest, note its specified dimensions and cross + # ref against the dictionary of known dimensions + # --------------------------------------------------------- + isfound = False + for i,line in enumerate(contents): + if((param.symbol in line) and \ + (not isfound) and \ + (('double' in line) or \ + ('char' in line) or \ + ('float' in line) or \ + ('int' in line))): + + isfound = True + + print('Filling {}'.format(param.symbol)) + + datatype = line.split()[0] + if(datatype.strip()=="float"): + param.datatype = float_type + elif(datatype.strip()=="double"): + param.datatype = double_type + elif(datatype.strip()=="char"): + param.datatype = char_type + elif(datatype.strip()=="int"): + param.datatype = int_type + else: + print('An unknown datatype: {}'.format(datatype.strip())) + print(' was encountered for parameter: {}'.format(param.symbol)) + exit(2) + + + p1=line.find('(')+1 + if(p1>0): + p2=line.find(')') + dims_str = line[p1:p2] + dims_splt = dims_str.split(',') + + for dimname in dims_splt: + dimsize = dim_dic.get(dimname.strip()) + if dimsize: + param.dim_namelist.append(dimname.strip()) + param.dim_sizelist.append(dimsize) + else: + print('An unknown dimension was requested:') + print(' parameter: {}'.format(param.symbol)) + print(' dimension name: {}'.format(dimname.strip())) + exit(2) + + param.ndims = len(param.dim_namelist) + + else: + param.ndims = 0 + + + + # Allocate and initialize the data space + if(param.ndims>0): + + param.data = -999*np.ones((param.dim_sizelist)) + else: + param.data = -999*np.ones((1)) + + + + + if(not isfound): + print('An unknown parameter was requested:') + print(' parameter: {}'.format(param.symbol)) + exit(2) + + # ----------------------------------------------------------- + # Now that the metadata has been read in, and we + # know the type of data and its dimensions, lets go retrieve + # and fill the values in + # ----------------------------------------------------------- + + + # First step is to identify the start of the data section: + # Also, identify the whatever line is next with a ':' + # --------------------------------------------------- + + iline0=-1 + for i,line in enumerate(contents): + if('data:' in line): + iline0 = i + break + + if(iline0==-1): + print('Could not find the data section of the CDL file?') + exit(2) + + # Look for the symbol, again, but now in the "data" section: + # ----------------------------------------------------------- + + isfound = False + contents=contents[iline0:] + for i,line in enumerate(contents): + + if(param.symbol in line): + + search_field=True + lcount=0 + multi_line='' + while(search_field and (lcount<100)): + multi_line+=contents[i+lcount] + if(multi_line.count(';')>0): + search_field=False + else: + search_field=True + lcount=lcount+1 + + # Parse the line + line_split = re.split(',|=',multi_line) + # Remove the variable name entry + del line_split[0] + + # This is for real numbers + if((param.datatype == float_type) or \ + (param.datatype == double_type)): + ival=0 + indx=0 + for str0 in line_split: + str="" + isnum=False + for s in str0: + if (s.isdigit() or s=='.'): + str+=s + isnum=True + elif(s == '_'): + str+=no_data_fill + isnum=True + if(isnum): + param.Add1DToXD(float(str),indx) + indx=indx+1 + else: + print('No-data values encountered during parameter read in') + print('for parameter {}'.format(param.symbol)) + print('bad value: {}'.format(str0)) + print('data: {}'.format(line_split)) + exit(2) + + # This is a string + # elif(param.datatype == 1): + # for str0 in line_split: + # # Loop several times to trim stuff off + # for i in range(5): + # str0=str0.strip().strip('\"').strip(';').strip() + # param.vals.append(str0) + + +# if(param.symbol == 'fates_hydr_thetas_node'): + + + + + return(param) + + + + + +# This routine returns a dictionary with dimension names and sizes +# ==================================================================== + +def CDLParseDims(file_name): + + fp = open(file_name,"r") + contents = fp.readlines() + fp.close() + + # Identify the line with the "dimensions:" tag + # Also, identify the whatever line is next with a ':' + # --------------------------------------------------- + + iline0=-1 + for i,line in enumerate(contents): + if('dimensions:' in line): + iline0 = i + break + + if(iline0==-1): + print("The CDL Parser could not find the dimensions section") + print(" in your output file") + print(" exiting...") + exit(2) + + iline1=-1 + for i,line in enumerate(contents): + if((':' in line) and \ + (i > iline0) and \ + ('"' not in line)): + iline1 = i + break + + if(iline1==-1): + print("The CDL Parser could not find a section") + print(" following the dimensions section.") + print(" exiting...") + exit(2) + + # Loop between the two and save the dimensions + # -------------------------------------------- + + dim_dic = {} + for i in range(iline0+1,iline1): + + # If there is an equals sign, then there is data + if('=' in contents[i]): + + # Split string into chunks + sline = contents[i].split() + dim_dic[sline[0]] = int(sline[2]) + + + if(len(dim_dic)==0): + print("No valid dimensions found in your CDL file") + print(" exiting...") + exit(2) + + return(dim_dic) diff --git a/functional_unit_testing/shared/py_src/F90ParamParse.py b/functional_unit_testing/shared/py_src/F90ParamParse.py new file mode 100644 index 0000000000..db4d4e7ac5 --- /dev/null +++ b/functional_unit_testing/shared/py_src/F90ParamParse.py @@ -0,0 +1,159 @@ +# ======================================================================================= +# +# This python module contains routines and utilities which will interpret the +# FATES fortran code base to return information on the use of parameters. +# This does not parse the CDL or NC files, this only parses the fortran code. +# +# This module will help: +# 1) List the parameters found in a given file +# 2) Determine the parameter names found therein +# 3) Determine the parameter's name in the parameter file +# +# Note: This module can be used to determine usage of any sybmol associated with +# the instantiation of a structure. Ie, you can search for all parameters +# in the 'EDPftvarcon_inst%' structure. In FATES, the EDParamsMod and SFParamsMod +# don't use a structure to hold their parameters though. +# +# ======================================================================================= + +import code # For development: code.interact(local=dict(globals(), **locals())) + + +class f90_param_type: + + # ----------------------------------------------- + # PFTParamType stucture. A list of these will be + # generated that denotes the PFT parameters used. + # ----------------------------------------------- + + def __init__(self,var_sym): + + self.var_sym = var_sym # Name of parameter in FORTRAN code + self.var_name = '' # Parameter's name in the parameter file + + +def GetSymbolUsage(filename,checkstr_in): + + # --------------------------------------------------------------------- + # This procedure will check a fortran file and return a list (non-unique) + # of all the PFT parameters found in the code. + # Note: This will only determine the symbol name in code, this will + # not determine the symbol name in the parameter file. + # --------------------------------------------------------------------- + + checkstr = checkstr_in.lower() + + f = open(filename,"r") + contents = f.readlines() + f.close() + + strclose = ',)( ' + + var_list = [] + found = False + + + for line in contents: + if checkstr in line.lower(): + + if(checkstr[-1] != '%'): + print('The GetSymbolUsage() procedure requires') + print(' that a structure ending with % is passed in') + print(' check_str: --{}--'.format(check_str)) + exit(2) + + # We compare all in lower-case + # There may be more than one parameter in a line, + # so evaluate, pop-off, and try again + + substr = line.lower() + + search_substr=True + + while(search_substr): + + p1 = substr.find(checkstr)+len(checkstr) + + pcomment = substr.find('!') + if(pcomment<0): + pcomment=1000 + + # This makes sure that if the line + # has a comment, that it does not come before + # the parameter symbol + + if( (p1>len(checkstr)) and (p1 < pcomment)): + found = True + + # Identify the symbol by starting at the first + # character after the %, and ending at a list + # of possible symols including space + substr2=substr[p1:] + pend0=-1 + for ch in strclose: + pend = substr2.find(ch) + if(pend>0): + substr2=substr2[:pend] + pend0=pend + + var_list.append(f90_param_type(substr2)) + if(pend0!=-1): + substr=substr[pend0:] + else: + print('Could not correctly identify the parameter string') + exit(2) + + else: + search_substr=False + + + + if(not found): + print('No parameters with prefix: {}'.format(checkstr)) + print('were found in file: {}'.format(filename)) + print('If this is expected, remove that file from search list.') + exit(2) + + + return(var_list) + + + + +def GetPFTParmFileSymbols(var_list,pft_filename): + + #--------------------------------------------------------------- + # This procedure will determine the parameter file symbol/name + # for a given PFT parameter name. This relies on specific + # file syntax in the PFT definitions file, so this is specific + # only to PFT parameters. + # -------------------------------------------------------------- + + f = open(pft_filename,"r") + contents = f.readlines() + f.close() + + var_name_list = [] + for var in var_list: + for i,line in enumerate(contents): + if (var.var_sym in line) and ('data' in line) and ('=' in line): + var.var_name = contents[i-2].split()[-1].strip('\'') + + return(var_list) + + +def MakeListUnique(list_in): + + # This procedure simply filters + # an input list and returns the unique entries + + unique_list = [] + for var in list_in: + found = False + for uvar in unique_list: + if (var.var_sym == uvar.var_sym): + found = True + if(not found): + unique_list.append(var) + + return(unique_list) diff --git a/functional_unit_testing/shared/py_src/PyF90Utils.py b/functional_unit_testing/shared/py_src/PyF90Utils.py new file mode 100644 index 0000000000..fa0a857980 --- /dev/null +++ b/functional_unit_testing/shared/py_src/PyF90Utils.py @@ -0,0 +1,17 @@ +import ctypes +from ctypes import * + + +# These are shortcuts that simply convert real, ints and stings +# into refernced cytype compliant arguments + +def c8(r8): + return(byref(c_double(r8))) + + +def ci(i8): + return(byref(c_int(i8))) + + +def cchar(fchar): + return(byref(c_char(fchar))) From 6e116349966f5f2cbfc87532603e7b7e7a7a172a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Sep 2019 14:06:06 -0700 Subject: [PATCH 024/114] Adding un-constrained mode for theta-psi-flc functions --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 324 +++++++++++------- .../shared/py_src/CDLParse.py | 4 +- 2 files changed, 198 insertions(+), 130 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 04923bd744..8f2dd2cb56 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -2,7 +2,7 @@ module FatesHydroUnitFunctionsMod ! This module contains hydraulics functions that are readily broken down into ! unit tests. These are functions that mostly operate on primitive - ! arguments, are smaller in scope, and are allowed to access the + ! arguments, are smaller in scope, and are allowed to access the ! parameter constants EDPftvarcon_inst and params use FatesConstantsMod, only : r8 => fates_r8 @@ -30,7 +30,7 @@ module FatesHydroUnitFunctionsMod ! Currently testing two different ways to represent rhizosphere shell ! volumes. The old way used a "representative" shell volume, the - ! new way is an absolute volume, in total cubic meters over the + ! new way is an absolute volume, in total cubic meters over the ! whole hectare. integer, parameter :: bcvol = 1 @@ -41,12 +41,14 @@ module FatesHydroUnitFunctionsMod integer, parameter :: campbell = 2 integer, parameter :: iswc = campbell + logical, parameter :: allow_unconstrained_theta = .true. - ! P-V curve: total RWC @ which elastic drainage begins [-] + + ! P-V curve: total RWC @ which elastic drainage begins [-] real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) - + ! P-V curve: total RWC @ which capillary reserves exhausted - real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) ! P-V curve: slope of capillary region of curve real(r8), allocatable :: cap_slp(:) @@ -72,6 +74,8 @@ module FatesHydroUnitFunctionsMod public :: xylemtaper public :: InitAllocatePlantMedia public :: SetPlantMediaParam + public :: solutepsi + public :: pressurepsi contains @@ -79,8 +83,8 @@ module FatesHydroUnitFunctionsMod ! ===================================================================================== subroutine InitAllocatePlantMedia(n_plant_media) - - ! We only allocate for plant porous media, we do + + ! We only allocate for plant porous media, we do ! not use these arrays to inform on soil relationships integer,intent(in) :: n_plant_media @@ -100,34 +104,34 @@ subroutine InitAllocatePlantMedia(n_plant_media) end subroutine InitAllocatePlantMedia ! ===================================================================================== - + subroutine SetPlantMediaParam(pm,rwcft_in,rwccap_in) ! To avoid complications that would arise from linking this ! module with the FatesHydraulicsMemMod.F90 during unit tests, we ! store some of these arrays that are indexed by "porous_media" ! as globals in this module. - + integer,intent(in) :: pm ! porous media index real(r8),intent(in) :: rwcft_in ! rwcft for this pm real(r8),intent(in) :: rwccap_in ! rwcap for this pm rwcft(pm) = rwcft_in rwccap(pm) = rwccap_in - + if (pm.eq.1) then ! Leaf tissue cap_slp(pm) = 0.0_r8 cap_int(pm) = 0.0_r8 cap_corr(pm) = 1.0_r8 else ! Non leaf tissues - cap_slp(pm) = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int(pm) = -cap_slp(pm) + hydr_psi0 + cap_slp(pm) = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int(pm) = -cap_slp(pm) + hydr_psi0 cap_corr(pm) = -cap_int(pm)/cap_slp(pm) end if - + return end subroutine SetPlantMediaParam - + ! ===================================================================================== subroutine Hydraulics_Tridiagonal(a, b, c, r, u) @@ -158,7 +162,7 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) real(r8) :: err ! solution error, in units of [m3/m3] real(r8) :: rel_err ! relative error, normalized by delta theta real(r8), parameter :: allowable_rel_err = 0.0001_r8 - + ! real(r8), parameter :: allowable_err = 1.e-6_r8 !---------------------------------------------------------------------- N=size(r,dim=1) @@ -210,7 +214,7 @@ end subroutine Hydraulics_Tridiagonal function flc_gs_from_psi( lwp, ft ) result( btran ) - ! + ! ! !DESCRIPTION: Calculates fractional loss of conductance ! across the stomata (gs). @@ -221,13 +225,13 @@ function flc_gs_from_psi( lwp, ft ) result( btran ) real(r8) :: btran btran = & - (1._r8 + & + (1._r8 + & (lwp/pft_p%hydr_p50_gs(ft))**pft_p%hydr_avuln_gs(ft))**(-1._r8) end function flc_gs_from_psi !===============================================================================! - + function dflcgsdpsi_from_psi(lwp, ft) result (dflcgsdpsi) ! Calculate the derivative of change in fractional loss of conductivity @@ -244,17 +248,17 @@ function dflcgsdpsi_from_psi(lwp, ft) result (dflcgsdpsi) p50_gs => pft_p%hydr_p50_gs) ! Stomatal PLC curve: water potential ! at 50% loss of gs,max [Pa] - + dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(ft))**avuln_gs(ft))**(-2._r8) * & avuln_gs(ft)/p50_gs(ft)*(lwp/p50_gs(ft))**(avuln_gs(ft)-1._r8) - + end associate - + end function dflcgsdpsi_from_psi !===============================================================================! - - function flc_from_psi(ft, pm, psi_node, suc_sat, bsw) result(flc_node) + + function flc_from_psi(ft, pm, th_in, psi_in, suc_sat, bsw) result(flc_node) ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting ! plant tissue or soil water potentials to a fractional loss of conductivity @@ -262,19 +266,29 @@ function flc_from_psi(ft, pm, psi_node, suc_sat, bsw) result(flc_node) ! !ARGUMENTS integer , intent(in) :: ft ! PFT index integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: psi_node ! water potential [MPa] + real(r8) , intent(in) :: th_in ! water content [m3/m3] + real(r8) , intent(in) :: psi_in ! water potential [MPa] real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" real(r8) :: flc_node ! frac loss of conductivity [-] - associate(& + associate(& avuln => pft_p%hydr_avuln_node , & ! PLC curve: vulnerability curve shape parameter [-] p50 => pft_p%hydr_p50_node & ! PLC curve: water potential at 50% loss of conductivity [Pa] ) - + if(pm <= 4) then - flc_node = 1._r8/(1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm)) + if(allow_unconstrained_theta) then + if(th_in pft_p%hydr_avuln_node, & ! vulnerability curve shape parameter [-] p50 => pft_p%hydr_p50_node & ! water potential at 50% loss of conductivity [Pa] ) if(pm <= 4) then - dflcdpsi_node = -1._r8 * (1._r8 + (psi_node/p50(ft,pm))**avuln(ft,pm))**(-2._r8) * & - avuln(ft,pm)/p50(ft,pm)*(psi_node/p50(ft,pm))**(avuln(ft,pm)-1._r8) + if(allow_unconstrained_theta) then + if(th_in pft_p%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction ) @@ -415,14 +442,14 @@ function th_from_psi(ft, pm, psi_node, th_sat, suc_sat, bsw) result(th_node) ! bc_in%watsat_sisl(1), & ! bc_in%watres_sisl(1), & ! th_node) - case (campbell) + case (campbell) call swcCampbell_satfrac_from_psi(psi_node, & (-1._r8)*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & bsw, & satfrac) call swcCampbell_th_from_satfrac(satfrac, & - th_sat, & + th_sat, & th_node) case default write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) @@ -431,13 +458,13 @@ function th_from_psi(ft, pm, psi_node, th_sat, suc_sat, bsw) result(th_node) end if end associate - + end function th_from_psi - + !===============================================================================! - + subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) - ! + ! ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. ! An analytical solution is not possible because quadratic smoothing functions ! are used to remove discontinuities in the PV curve. @@ -463,11 +490,11 @@ subroutine bisect_pv(ft, pm, lower, upper, xtol, ytol, psi_node, th_node) real(r8) :: y_new ! corresponding y value at x.new real(r8) :: f_new ! y difference between new y guess at x.new and target y real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - integer :: nitr ! number of iterations + integer :: nitr ! number of iterations if(psi_node > 0.0_r8) then write(fates_log(),*)'Error: psi_note become positive, psi_node=',psi_node - call endrun(msg=errMsg(sourcefile, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) endif y_lo = psi_from_th(ft, pm,lower) @@ -500,9 +527,9 @@ end subroutine bisect_pv !===============================================================================! - function psi_from_th(ft, pm, th_node, th_sat, suc_sat, bsw) result(psi_node) + function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) - ! + ! ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) ! at a given water content (th) ! @@ -511,26 +538,40 @@ function psi_from_th(ft, pm, th_node, th_sat, suc_sat, bsw) result(psi_node) ! !ARGUMENTS integer , intent(in) :: ft ! PFT index integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: th_node ! water content [m3 m-3] + real(r8) , intent(in) :: th_in ! water content [m3 m-3] real(r8), optional,intent(in) :: th_sat ! water content at saturation ! (porosity for soil) [m3 m-3] real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] - real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" ! ! !LOCAL VARIABLES: - real(r8) :: satfrac ! saturation fraction [0-1] + real(r8) :: satfrac ! saturation fraction [0-1] + ! Result real(r8) :: psi_node ! water potential [MPa] - + real(r8) :: dpsidth_resid ! Change in psi wrt th @ residual WC [MPa/[m3/m3]] + real(r8) :: psi_resid ! Psi at residual WC [MPa] if(pm <= 4) then ! plant - - call tq2(ft, pm, th_node*cap_corr(pm), psi_node) - - print*,"F90: ",psi_node + if(allow_unconstrained_theta) then + if(th_in>pft_p%hydr_thetas_node(ft,pm)) then + ! Hard cap water content at saturation + call tq2(ft, pm, pft_p%hydr_thetas_node(ft,pm)*cap_corr(pm), psi_node) + elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then + ! The derivative at the hard-cap is 0 + dpsidth = 0._r8 + elseif(th_in Date: Tue, 17 Sep 2019 14:13:01 -0700 Subject: [PATCH 025/114] Adding the hydro unit test. --- .../hydro/AutoGenVarCon.py | 185 +++++++ .../hydro/HydroUTestDriver.py | 501 ++++++++++++++++++ functional_unit_testing/hydro/bld/README | 0 .../hydro/build_hydro_f90_objects.sh | 61 +++ .../hydro/f90_src/EDParamsHydroMod.F90 | 62 +++ functional_unit_testing/hydro/f90_src/README | 0 6 files changed, 809 insertions(+) create mode 100644 functional_unit_testing/hydro/AutoGenVarCon.py create mode 100644 functional_unit_testing/hydro/HydroUTestDriver.py create mode 100644 functional_unit_testing/hydro/bld/README create mode 100755 functional_unit_testing/hydro/build_hydro_f90_objects.sh create mode 100644 functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 create mode 100644 functional_unit_testing/hydro/f90_src/README diff --git a/functional_unit_testing/hydro/AutoGenVarCon.py b/functional_unit_testing/hydro/AutoGenVarCon.py new file mode 100644 index 0000000000..3288f9280a --- /dev/null +++ b/functional_unit_testing/hydro/AutoGenVarCon.py @@ -0,0 +1,185 @@ +# ============================================================================= +# Walk through lines of a file, if a line contains +# the string of interest (EDPftvarcon_inst), then +# parse the string to find the variable name, and save that +# to the list +# ============================================================================= + +import imp +import code # For development: code.interact(local=dict(globals(), **locals())) + +F90ParamParse = imp.load_source('F90ParamParse','../shared/py_src/F90ParamParse.py') +CDLParse = imp.load_source('CDLParse','../shared/py_src/CDLParse.py') + + +from F90ParamParse import f90_param_type, GetSymbolUsage, GetPFTParmFileSymbols, MakeListUnique +from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type + + +# ------------------------------------------------------------------------------------- +# Check through the fortran Code we are coupling with, determine the list of parameters +# that we need. +# The procedure GetSymbolUsage() returns a list of strings (non-unique) +# ------------------------------------------------------------------------------------- + +check_str = 'pft_p%' +var_list0 = GetSymbolUsage('../../biogeophys/FatesHydroUnitFunctionsMod.F90',check_str) + +# This is the unique list of PFT parameters found in the salient Fortran code + +var_list = MakeListUnique(var_list0) + +# Now look through EDPftvarcon.F90 to determine the variable name in file +# that is associated with the variable pointer + +var_list = GetPFTParmFileSymbols(var_list,'../../main/EDPftvarcon.F90') + +#var_list.append(f90_param_type('parteh_mode')) +#var_list[-1].var_name = 'fates_parteh_mode' + + +# ------------------------------------------------------------- +# We can now cross reference our list of parameters against +# the parameter file. This will create a new list of parameters +# however in the form of a dictionary. This dictionary of +# entries is accessible by its symbol name, and will also +# read in and store the actual parameter values from the file. +# We will use the default file to get the dimensionality. +# +# NOTE: THE CDLPARSE PROCEDURE WILL LOAD IN THE DATA, +# BUT WE DONT NEED IT. THE CDLPARSE PARAM ROUTINE +# IS JUST USED TO GET THE CORRECT DIMENSIONS. THUS WE +# CAN JUST POINT TO THE DEFAULT CDL FILE IN VERSION CONTROL +# +# ------------------------------------------------------------- + + +default_file_relpath = '../../parameter_files/fates_params_default.cdl' + +dims = CDLParseDims(default_file_relpath) + +parms = {} +for elem in var_list: + parms[elem.var_sym] = CDLParseParam(default_file_relpath,cdl_param_type(elem.var_name),dims) + print('Finished loading PFT parameters') + + + +f = open("../shared/f90_src/UnitWrapMod.F90_in", "r") +contents = f.readlines() +f.close() + +# ADD ARGUMENTS TO EDPFTVARCONALLOC +# --------------------------------- + +for i,str in enumerate(contents): + if 'ARGUMENT_IN1' in str: + index0=i + +str='' +icount=0 +for key, value in dims.iteritems(): + print('{}'.format(key)) + if(icount==0): + str+=key + else: + str+=(', & \n '+key) + icount+=1 + +strsplit = contents[index0].split('ARGUMENT_IN1') +strreplace = strsplit[0]+str+strsplit[1] + +contents[index0] = strreplace + + +for i,str in enumerate(contents): + if 'ARGUMENT_DEF1' in str: + index0=i + +str='' +for key, value in dims.iteritems(): + str+=(' integer,intent(in) :: '+key+'\n') + + +contents[index0] = str + + + + + +# Identify where we define the variables, and insert the variable definitions + +for i,str in enumerate(contents): + if 'VARIABLE-DEFINITIONS-HERE' in str: + index0=i + +index=index0+2 +for symbol, var in parms.iteritems(): + + if(var.ndims==1): + contents.insert(index,' real(r8),pointer :: {}(:)\n'.format(symbol)) + elif(var.ndims==2): + contents.insert(index,' real(r8),pointer :: {}(:,:)\n'.format(symbol)) + else: + print('Incorrect number of dims...') + exit(-2) + index=index+1 + +# Identify where we do the pointer assignments, and insert the pointer assignments + + +for i,str in enumerate(contents): + if 'POINTER-SPECIFICATION-HERE' in str: + index0=i + +index=index0+2 +for symbol, var in parms.iteritems(): + + # Generate the dimension names + + dim_alloc_str='' + icount=0 + for dimname in reversed(var.dim_namelist): + if(icount==0): + dim_alloc_str+=dimname + else: + dim_alloc_str+=(','+dimname) + icount+=1 + + + if(var.ndims==1): + ins_l1='\t allocate(EDPftvarcon_inst%{}({}))\n'.format(symbol,dim_alloc_str) + ins_l2='\t EDPftvarcon_inst%{}(:) = fates_unset_r8\n'.format(symbol) + ins_l3='\t iv1 = iv1 + 1\n' + ins_l4='\t EDPftvarcon_ptr%var1d(iv1)%var_name = "{}"\n'.format(var.symbol) + ins_l5='\t EDPftvarcon_ptr%var1d(iv1)%var_rp => EDPftvarcon_inst%{}\n'.format(symbol) + ins_l6='\t EDPftvarcon_ptr%var1d(iv1)%vtype = 1\n' + ins_l7='\n' + elif(var.ndims==2): + ins_l1='\t allocate(EDPftvarcon_inst%{}({}))\n'.format(symbol,dim_alloc_str) + ins_l2='\t EDPftvarcon_inst%{}(:,:) = fates_unset_r8\n'.format(symbol) + ins_l3='\t iv2 = iv2 + 1\n' + ins_l4='\t EDPftvarcon_ptr%var2d(iv2)%var_name = "{}"\n'.format(var.symbol) + ins_l5='\t EDPftvarcon_ptr%var2d(iv2)%var_rp => EDPftvarcon_inst%{}\n'.format(symbol) + ins_l6='\t EDPftvarcon_ptr%var2d(iv2)%vtype = 1\n' + ins_l7='\n' + else: + print('Auto-generating FORTRAN parameter code does not handle >2D') + print(symbol) + print(var.ndims) + exit(2) + + contents.insert(index,ins_l1) + contents.insert(index+1,ins_l2) + contents.insert(index+2,ins_l3) + contents.insert(index+3,ins_l4) + contents.insert(index+4,ins_l5) + contents.insert(index+5,ins_l6) + contents.insert(index+6,ins_l7) + index=index+7 + + +f = open("f90_src/UnitWrapMod.F90", "w+") +contents = "".join(contents) +f.write(contents) +f.close() diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py new file mode 100644 index 0000000000..49fd6baf1d --- /dev/null +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -0,0 +1,501 @@ +# ======================================================================================= +# +# For usage: $python HydroUTestDriver.py --help +# +# This script runs unit tests on the hydraulics functions. +# +# +# ======================================================================================= + +import matplotlib as mpl +#mpl.use('Agg') +import matplotlib.pyplot as plt +from datetime import datetime +import argparse +#from matplotlib.backends.backend_pdf import PdfPages +import platform +import numpy as np +import os +import sys +import getopt +import code # For development: code.interact(local=dict(globals(), **locals())) +import time +import imp +import ctypes +from ctypes import * +from operator import add + + +CDLParse = imp.load_source('CDLParse','../shared/py_src/CDLParse.py') +F90ParamParse = imp.load_source('F90ParamParse','../shared/py_src/F90ParamParse.py') +PyF90Utils = imp.load_source('PyF90Utils','../shared/py_src/PyF90Utils.py') + +from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type +from F90ParamParse import f90_param_type, GetSymbolUsage, GetPFTParmFileSymbols, MakeListUnique +from PyF90Utils import c8, ci, cchar + +# Load the fortran objects via CTYPES + +f90_edparams_obj = ctypes.CDLL('bld/EDParamsHydroMod.o',mode=ctypes.RTLD_GLOBAL) +f90_constants_obj = ctypes.CDLL('bld/FatesConstantsMod.o',mode=ctypes.RTLD_GLOBAL) +f90_unitwrap_obj = ctypes.CDLL('bld/UnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) +f90_hydrofuncs_obj = ctypes.CDLL('bld/FatesHydroUnitFunctionsMod.o',mode=ctypes.RTLD_GLOBAL) + +# Alias the F90 functions, specify the return type +# ----------------------------------------------------------------------------------- +psi_from_th = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_psi_from_th +psi_from_th.restype = c_double + +dpsidth_from_th= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dpsidth_from_th +dpsidth_from_th.restype = c_double + +flc_from_psi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_flc_from_psi +flc_from_psi.restype = c_double + +dflcdpsi_from_psi= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dflcdpsi_from_psi +dflcdpsi_from_psi.restype = c_double + +solutepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_solutepsi +pressurepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_pressurepsi + + +# Some constants +rwcft = [1.0,0.958,0.958,0.958] +rwccap = [1.0,0.947,0.947,0.947] +pm_leaf = 1 +pm_stem = 2 +pm_aroot = 4 +pm_troot = 3 + +# ======================================================================================== +# ======================================================================================== +# Main +# ======================================================================================== +# ======================================================================================== + + +def main(argv): + + # First check to make sure python 2.7 is being used + version = platform.python_version() + verlist = version.split('.') + + if( not ((verlist[0] == '2') & (verlist[1] == '7') & (int(verlist[2])>=15) ) ): + print("The PARTEH driver mus be run with python 2.7") + print(" with tertiary version >=15.") + print(" your version is {}".format(version)) + print(" exiting...") + sys.exit(2) + + # Read in the arguments + # ======================================================================================= + + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + parser.add_argument('--cdl-file', dest='cdlfile', type=str, \ + help="Input CDL filename. Required.", required=True) + + args = parser.parse_args() + + + + # ------------------------------------------------------------------------------------- + # Check through the fortran Code we are coupling with, determine the list of parameters + # that we need. + # The procedure GetSymbolUsage() returns a list of strings (non-unique) + # ------------------------------------------------------------------------------------- + + check_str = 'pft_p%' + var_list0 = GetSymbolUsage('../../biogeophys/FatesHydroUnitFunctionsMod.F90',check_str) + + # This is the unique list of PFT parameters found in the salient Fortran code + + var_list = MakeListUnique(var_list0) + + # Now look through EDPftvarcon.F90 to determine the variable name in file + # that is associated with the variable pointer + + var_list = GetPFTParmFileSymbols(var_list,'../../main/EDPftvarcon.F90') + + # ------------------------------------------------------------- + # We can now cross reference our list of parameters against + # the parameter file. This will create a new list of parameters + # however in the form of a dictionary. This dictionary of + # entries is accessible by its symbol name, and will also + # read in and store the actual parameter values from the file. + # ------------------------------------------------------------- + + dims = CDLParseDims(args.cdlfile) + pftparms = {} + for elem in var_list: + pftparms[elem.var_sym] = CDLParseParam(args.cdlfile,cdl_param_type(elem.var_name),dims) + print('Finished loading PFT parameters') + + num_pfts = dims['fates_pft'] + + scalarparms = {} + scalarparms['hydr_psi0'] = CDLParseParam(args.cdlfile,cdl_param_type('fates_hydr_psi0'),dims) + scalarparms['hydr_psicap'] = CDLParseParam(args.cdlfile,cdl_param_type('fates_hydr_psicap'),dims) + + + + + # Allocate PFT arrays in the fortran objects + iret=f90_unitwrap_obj.__edpftvarcon_MOD_edpftvarconalloc(ci(dims['fates_string_length']), \ + ci(dims['fates_history_size_bins']), \ + ci(dims['fates_NCWD']), \ + ci(dims['fates_prt_organs']), \ + ci(dims['fates_litterclass']), \ + ci(dims['fates_history_height_bins']), \ + ci(dims['fates_history_age_bins']), \ + ci(dims['fates_hydr_organs']), \ + ci(dims['fates_pft']), \ + ci(dims['fates_variants']), \ + ci(dims['fates_leafage_class'])) + + + + # Set the PFT arrays + for pft_key,pft_obj in pftparms.iteritems(): + for idim in range(np.int(np.prod(pft_obj.dim_sizelist))): + if(pft_obj.ndims==1): + idim1 = idim + idim2 = 0 + rdata = pft_obj.data[idim] + idata = np.int(pft_obj.data[idim]) + else: + idim2 = np.mod(idim,num_pfts) + idim1 = np.int(idim/num_pfts) + rdata = pft_obj.data[idim1,idim2] + idata = np.int(pft_obj.data[idim1,idim2]) + iret = f90_unitwrap_obj.__edpftvarcon_MOD_edpftvarconpyset(c8(rdata), \ + ci(idata), \ + ci(idim2+1), \ + ci(idim1+1), \ + c_char_p(pft_obj.symbol.strip()), \ + c_long(len(pft_obj.symbol.strip()))) + + # Push the scalar params data to fortran + + iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psi0'].data[0]), \ + c_char_p(scalarparms['hydr_psi0'].symbol.strip()), \ + c_long(len(scalarparms['hydr_psi0'].symbol.strip()))) + + iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psicap'].data[0]), \ + c_char_p(scalarparms['hydr_psicap'].symbol.strip()), \ + c_long(len(scalarparms['hydr_psicap'].symbol.strip()))) + + + # Initialize local objects in the unit test + iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_initallocateplantmedia(ci(4)) + iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(1),c8(rwcft[0]),c8(rwccap[0])) + iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(2),c8(rwcft[1]),c8(rwccap[1])) + iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(3),c8(rwcft[2]),c8(rwccap[2])) + iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(4),c8(rwcft[3]),c8(rwccap[3])) + + + + + # Test 1 For a set of thetas, calculate psi for each pm. + # =================================================================================== + + pft1 = 1 + pft2 = 2 + + npts = 1000 + + min_theta = 0.01 + max_theta = 0.99 + min_leaf_theta = pftparms['hydr_resid_node'].data[pm_leaf-1,pft1-1] + max_leaf_theta = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft1-1] + min_stem_theta = pftparms['hydr_resid_node'].data[pm_stem-1,pft1-1] + max_stem_theta = pftparms['hydr_thetas_node'].data[pm_stem-1,pft1-1] + min_troot_theta = pftparms['hydr_resid_node'].data[pm_troot-1,pft1-1] + max_troot_theta = pftparms['hydr_thetas_node'].data[pm_troot-1,pft1-1] + min_aroot_theta = pftparms['hydr_resid_node'].data[pm_aroot-1,pft1-1] + max_aroot_theta = pftparms['hydr_thetas_node'].data[pm_aroot-1,pft1-1] + + min_leaf_theta2 = pftparms['hydr_resid_node'].data[pm_leaf-1,pft2-1] + min_stem_theta2 = pftparms['hydr_resid_node'].data[pm_stem-1,pft2-1] + min_stem_theta2 = pftparms['hydr_resid_node'].data[pm_troot-1,pft2-1] + min_stem_theta2 = pftparms['hydr_resid_node'].data[pm_aroot-1,pft2-1] + + + + theta = np.linspace(min_theta, max_theta, num=npts-1) + leaf_theta = np.linspace(min_leaf_theta,max_leaf_theta, num=npts) + stem_theta = np.linspace(min_stem_theta,max_stem_theta, num=npts) + troot_theta = np.linspace(min_troot_theta,max_troot_theta, num=npts) + aroot_theta = np.linspace(min_aroot_theta,max_aroot_theta, num=npts) + + leaf_theta2 = np.linspace(min_leaf_theta2,max_leaf_theta, num=npts) + + # "full" range psi's + leaf_fpsi = np.zeros(shape=np.shape(theta),dtype=np.float64) + stem_fpsi = np.zeros(shape=np.shape(theta),dtype=np.float64) + troot_fpsi = np.zeros(shape=np.shape(theta),dtype=np.float64) + aroot_fpsi = np.zeros(shape=np.shape(theta),dtype=np.float64) + + # "constrained" range psi's + leaf_cpsi = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) + leaf_cpsi2 = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) + stem_cpsi = np.zeros(shape=np.shape(stem_theta),dtype=np.float64) + troot_cpsi = np.zeros(shape=np.shape(troot_theta),dtype=np.float64) + aroot_cpsi = np.zeros(shape=np.shape(aroot_theta),dtype=np.float64) + + + mpl.rcParams.update({'font.size': 15}) + + + # Initialize the return variable + cpsi = c_double(0) + + + # Find PSI for each theta + for i,th in enumerate(theta): + leaf_fpsi[i] = psi_from_th(ci(pft1), ci(pm_leaf), c8(th)) + stem_fpsi[i] = psi_from_th(ci(pft1), ci(pm_stem), c8(th)) + troot_fpsi[i] = psi_from_th(ci(pft1), ci(pm_troot), c8(th)) + aroot_fpsi[i] = psi_from_th(ci(pft1), ci(pm_aroot), c8(th)) + + for i,th in enumerate(leaf_theta): + leaf_cpsi[i] = psi_from_th(ci(pft1), ci(pm_leaf), c8(th)) + + for i,th in enumerate(leaf_theta2): + leaf_cpsi2[i] = psi_from_th(ci(pft2),ci(pm_leaf),c8(th)) + + for i,th in enumerate(stem_theta): + stem_cpsi[i] = psi_from_th(ci(pft1), ci(pm_stem), c8(th)) + + for i,th in enumerate(troot_theta): + troot_cpsi[i] = psi_from_th(ci(pft1), ci(pm_troot), c8(th)) + + for i,th in enumerate(aroot_theta): + aroot_cpsi[i] = psi_from_th(ci(pft1), ci(pm_aroot), c8(th)) + + + + fig0, (ax1,ax2) = plt.subplots(2) + ax1.plot(theta,leaf_fpsi,label='Leaf') + ax1.plot(theta,stem_fpsi,label='Stem') + ax1.plot(theta,troot_fpsi,label='Troot') + ax1.plot(theta,aroot_fpsi,label='Aroot') + ax1.grid(True) + ax1.set_ylabel('Psi') + ax1.set_ylim((-10,10)) + ax1.set_xlim((0,1)) + ax1.set_title('Unconstrained Range') + + ax2.plot(leaf_theta,leaf_cpsi,label=r'Leaf') + ax2.plot(stem_theta,stem_cpsi,label='Stem') + ax2.plot(troot_theta,troot_cpsi,label='Troot') + ax2.plot(aroot_theta,aroot_cpsi,label='Aroot') + ax2.grid(True) + ax2.set_xlabel('Theta') + ax2.set_ylabel('Psi') + ax2.set_ylim((-10,0)) + ax2.set_xlim((0,1)) + ax2.set_title('Constrained Residual and Sat') + ax2.legend(loc='lower right') + plt.tight_layout() + + + # Compare how resid and sat effect the curve + fig1, ax1 = plt.subplots(1) + ax1.plot(leaf_theta,leaf_cpsi,label='pft1') + ax1.plot(leaf_theta2,leaf_cpsi2,label='pft2') + ax1.grid(True) + ax1.set_ylabel('Psi') + ax1.set_xlabel('theta') +# ax1.set_ylim((-30,0)) + ax1.set_xlim((0,1)) + ax1.set_title('Comparing PFT 1 and PFT 2') + + + # Lets look at the solute curve, is that the one that is breaking? + + resid = pftparms['hydr_resid_node'].data[pm_leaf-1,pft2-1] + thetas = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft2-1] + pinot = pftparms['hydr_pinot_node'].data[pm_leaf-1,pft2-1] + epsil = pftparms['hydr_epsil_node'].data[pm_leaf-1,pft2-1] + sol_psi = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) + ela_psi = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) + sol_psi2 = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) + ela_psi2 = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) + + print(resid,thetas,pinot,epsil) + + + for i,th in enumerate(leaf_theta2): + sol_psi[i] = pinot*thetas*(rwcft[pm_leaf-1] - resid) / (th - thetas*resid) + ela_psi[i] = epsil * (th - thetas*rwcft[pm_leaf-1]) / (thetas*(rwcft[pm_leaf-1]-resid)) - pinot + + iret = solutepsi(ci(pft2),ci(pm_leaf),c8(th),byref(cpsi)) + sol_psi2[i] = cpsi.value + iret = pressurepsi(ci(pft2),ci(pm_leaf),c8(th),byref(cpsi)) + ela_psi2[i] = cpsi.value + + + fig11,ax1 = plt.subplots(1) + ax1.plot(leaf_theta2,sol_psi,label='solute psi') + ax1.plot(leaf_theta2,ela_psi,label='press psi') + ax1.plot(leaf_theta2,sol_psi2,label='f(sol)') + ax1.plot(leaf_theta2,ela_psi2,label='f(ela)') + ax1.legend(loc='lower right') + ax1.grid(True) + + + + # Derivative Check on PSI + # ----------------------------------------------------------------------------------- + + leaf_dpsidth = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) + leaf_dpsidthc = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) + for i,th in enumerate(leaf_theta[1:-2]): + leaf_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_leaf), c8(th)) + leaf_dpsidthc[i] = (leaf_cpsi[i+1]-leaf_cpsi[i-1])/(leaf_theta[i+1]-leaf_theta[i-1]) + + + + # Derivative Check + stem_dpsidth = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) + stem_dpsidthc = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) + for i,th in enumerate(stem_theta[1:-2]): + stem_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_stem), c8(th)) + stem_dpsidthc[i] = (stem_cpsi[i+1]-stem_cpsi[i-1])/(stem_theta[i+1]-stem_theta[i-1]) + + + # Derivative Check + troot_dpsidth = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) + troot_dpsidthc = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) + for i,th in enumerate(troot_theta[1:-2]): + troot_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_troot), c8(th)) + troot_dpsidthc[i] = (troot_cpsi[i+1]-troot_cpsi[i-1])/(troot_theta[i+1]-troot_theta[i-1]) + + # Derivative Check + aroot_dpsidth = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + aroot_dpsidthc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + for i,th in enumerate(aroot_theta[1:-2]): + aroot_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_aroot), c8(th)) + aroot_dpsidthc[i] = (aroot_cpsi[i+1]-aroot_cpsi[i-1])/(aroot_theta[i+1]-aroot_theta[i-1]) + + fig2, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(12,10)) + ax1.plot(leaf_theta,leaf_dpsidth,label='dpsidth') + ax1.plot(leaf_theta,leaf_dpsidthc,label='DPsi/Dtheta') + ax1.set_ylim((-10,100)) + ax1.legend(loc='lower left') + ax1.set_title('Leaf') + ax1.set_ylabel('dpsi/dth') + + ax2.plot(stem_theta,stem_dpsidth) + ax2.plot(stem_theta,stem_dpsidthc) + ax2.set_ylim((-10,100)) + ax2.set_title('Stem') + ax2.legend(loc='lower left') + + ax3.plot(troot_theta,troot_dpsidth,label='dpsidth') + ax3.plot(troot_theta,troot_dpsidthc,label='DPsi/Dtheta') + ax3.set_ylim((-10,100)) + ax3.set_title('TRoot') + ax3.set_ylabel('dpsi/dth') + ax3.set_xlabel('theta') + + ax4.plot(aroot_theta,aroot_dpsidth,label='dpsidth') + ax4.plot(aroot_theta,aroot_dpsidthc,label='DPsi/Dtheta') + ax4.set_ylim((-10,100)) + ax4.set_title('ARoot') + ax4.set_xlabel('theta') + + + # Plot out FTC/PSI + # Find PSI for each theta + leaf_cflc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + leaf_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + leaf_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + stem_cflc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + stem_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + stem_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + troot_cflc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + troot_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + troot_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + aroot_cflc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + aroot_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + aroot_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + + + for i,psi in enumerate(leaf_cpsi): + leaf_cflc[i] = flc_from_psi(ci(pft1), ci(pm_leaf), c8(psi)) + leaf_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_leaf),c8(psi)) + + for i,psi in enumerate(stem_cpsi): + stem_cflc[i] = flc_from_psi(ci(pft1), ci(pm_stem), c8(psi)) + stem_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_stem),c8(psi)) + + for i,psi in enumerate(troot_cpsi): + troot_cflc[i] = flc_from_psi(ci(pft1), ci(pm_troot), c8(psi)) + troot_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_troot),c8(psi)) + + for i,psi in enumerate(aroot_cpsi): + aroot_cflc[i] = flc_from_psi(ci(pft1), ci(pm_aroot), c8(psi)) + aroot_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_aroot),c8(psi)) + + # back-calculate the derivative + for i,psi in enumerate(leaf_cpsi[1:-2]): + leaf_dflcdpsic[i] = (leaf_cflc[i+1]-leaf_cflc[i-1]) / \ + (leaf_cpsi[i+1]-leaf_cpsi[i-1]) + + for i,psi in enumerate(stem_cpsi[1:-2]): + stem_dflcdpsic[i] = (stem_cflc[i+1]-stem_cflc[i-1]) / \ + (stem_cpsi[i+1]-stem_cpsi[i-1]) + + for i,psi in enumerate(troot_cpsi[1:-2]): + troot_dflcdpsic[i] = (troot_cflc[i+1]-troot_cflc[i-1]) / \ + (troot_cpsi[i+1]-troot_cpsi[i-1]) + + for i,psi in enumerate(aroot_cpsi[1:-2]): + aroot_dflcdpsic[i] = (aroot_cflc[i+1]-aroot_cflc[i-1]) / \ + (aroot_cpsi[i+1]-aroot_cpsi[i-1]) + + fig3, ax1 = plt.subplots(1) + ax1.plot(leaf_cpsi,leaf_cflc,label='Leaf') + ax1.plot(stem_cpsi,stem_cflc,label='Stem') + ax1.plot(troot_cpsi,troot_cflc,label='Troot') + ax1.plot(aroot_cpsi,aroot_cflc,label='Aroot') + ax1.grid(True) + ax1.set_ylabel('FTC') + ax1.set_xlabel('Psi') + ax2.legend(loc='upper left') + plt.tight_layout() + + + fig4, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(12,10)) + ax1.plot(leaf_cpsi,leaf_dflcdpsi,label='function') + ax1.plot(leaf_cpsi,leaf_dflcdpsic,label='discrete') + ax1.legend(loc='upper left') + ax1.set_ylabel('dFLC/dPSI') + ax1.set_title('Leaf') + + ax2.plot(stem_cpsi,stem_dflcdpsi) + ax2.plot(stem_cpsi,stem_dflcdpsic) + ax2.set_title('Stem') + + ax3.plot(leaf_cpsi,leaf_dflcdpsi) + ax3.plot(leaf_cpsi,leaf_dflcdpsic) + ax3.set_title('TRoot') + ax3.set_xlabel('Psi') + ax3.set_ylabel('dFLC/dPSI') + + ax4.plot(leaf_cpsi,leaf_dflcdpsi,label='dpsidth') + ax4.plot(leaf_cpsi,leaf_dflcdpsic,label='DPsi/Dtheta') + ax4.set_title('ARoot') + ax4.set_xlabel('Psi') + + + plt.show() + +# code.interact(local=dict(globals(), **locals())) + +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main(sys.argv) diff --git a/functional_unit_testing/hydro/bld/README b/functional_unit_testing/hydro/bld/README new file mode 100644 index 0000000000..e69de29bb2 diff --git a/functional_unit_testing/hydro/build_hydro_f90_objects.sh b/functional_unit_testing/hydro/build_hydro_f90_objects.sh new file mode 100755 index 0000000000..ad934d4d77 --- /dev/null +++ b/functional_unit_testing/hydro/build_hydro_f90_objects.sh @@ -0,0 +1,61 @@ +#!/bin/bash + +# Path to FATES src + +FC='gfortran' + +F_OPTS="-shared -fPIC -g -ffpe-trap=zero,overflow,underflow -fbacktrace -fbounds-check" +#F_OPTS="-shared -fPIC -O" + + +MOD_FLAG="-J" + +rm -f bld/*.o +rm -f bld/*.mod + + +# First copy over the FatesConstants file, but change the types of the fates_r8 and fates_int + +old_fates_r8_str=`grep -e integer ../../main/FatesConstantsMod.F90 | grep fates_r8 | sed 's/^[ \t]*//;s/[ \t]*$//'` +new_fates_r8_str='use iso_c_binding, only: fates_r8 => c_double' + +old_fates_int_str=`grep -e integer ../../main/FatesConstantsMod.F90 | grep fates_int | sed 's/^[ \t]*//;s/[ \t]*$//'` +new_fates_int_str='use iso_c_binding, only: fates_int => c_int' + +# Add the new lines (need position change, don't swap) + +sed "/implicit none/i $new_fates_r8_str" ../../main/FatesConstantsMod.F90 > f90_src/FatesConstantsMod.F90 +sed -i "/implicit none/i $new_fates_int_str" f90_src/FatesConstantsMod.F90 +sed -i "/private /i public :: fates_r8" f90_src/FatesConstantsMod.F90 +sed -i "/private /i public :: fates_int" f90_src/FatesConstantsMod.F90 + +# Delete the old lines + +sed -i "/$old_fates_r8_str/d" f90_src/FatesConstantsMod.F90 +sed -i "/$old_fates_int_str/d" f90_src/FatesConstantsMod.F90 + + +# This re-writes the wrapper so that it uses all the correct parameters +# in FatesAllometryMod.F90 +python AutoGenVarCon.py + + +# Procedure for auto-generating AllomUnitWrap +# 1) scan FatesAllometry and create list of EDPftVarcon_inst variables +# 2) scan EDpftVarcon and get the name of the in-file parameter names associated +# with these variables + + + +# Build the new file with constants + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o f90_src/FatesConstantsMod.F90 + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/UnitWrapMod.o f90_src/UnitWrapMod.F90 + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroUnitFunctionsMod.o ../../biogeophys/FatesHydroUnitFunctionsMod.F90 + + + diff --git a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 new file mode 100644 index 0000000000..84b31ecf80 --- /dev/null +++ b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 @@ -0,0 +1,62 @@ + +! THIS IS A STRIPPED DOWN VERSION OF main/EDParamsMod.F90 + + +module EDParamsMod + ! + ! module that deals with reading the ED parameter file + ! + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + use FatesConstantsMod, only : r8 => fates_r8 + + implicit none + private + save + + integer(kind=c_int), parameter :: param_string_length = 32 + + + ! Hydraulics Control Parameters + ! ---------------------------------------------------------------------------------------------- + real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface + ! soil to root direction (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" + + real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface + ! root to soil direciton (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" + + real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" + + real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" + + public :: EDParamsPySet + +contains + + subroutine EDParamsPySet(rval,name) + + implicit none + ! Arguments + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + + if(trim(name) == trim(hydr_name_psi0))then + hydr_psi0 = rval + elseif(trim(name) == trim(hydr_name_psicap))then + hydr_psicap = rval + else + print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) + stop + end if + + return + end subroutine EDParamsPySet + + + + +end module EDParamsMod diff --git a/functional_unit_testing/hydro/f90_src/README b/functional_unit_testing/hydro/f90_src/README new file mode 100644 index 0000000000..e69de29bb2 From dcf3d4ec5fe7ff2ae1c590f80ef305b34be5cc92 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 17 Sep 2019 17:54:55 -0700 Subject: [PATCH 026/114] Finished tweaks on hydro unit test v0. Updated calling routines in main hydro routine to use new functions. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 25 +- biogeophys/FatesPlantHydraulicsMod.F90 | 221 +++++------ .../hydro/HydroUTestDriver.py | 356 ++++++++---------- 3 files changed, 281 insertions(+), 321 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 8f2dd2cb56..0609294f3c 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -74,12 +74,9 @@ module FatesHydroUnitFunctionsMod public :: xylemtaper public :: InitAllocatePlantMedia public :: SetPlantMediaParam - public :: solutepsi - public :: pressurepsi - + contains - ! ===================================================================================== subroutine InitAllocatePlantMedia(n_plant_media) @@ -271,6 +268,7 @@ function flc_from_psi(ft, pm, th_in, psi_in, suc_sat, bsw) result(flc_node) real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" + real(r8) :: psi_resid ! matric potential @ residual WC [MPa] real(r8) :: flc_node ! frac loss of conductivity [-] associate(& @@ -281,7 +279,7 @@ function flc_from_psi(ft, pm, th_in, psi_in, suc_sat, bsw) result(flc_node) if(pm <= 4) then if(allow_unconstrained_theta) then if(th_inpft_p%hydr_thetas_node(ft,pm)) then ! Hard cap water content at saturation call tq2(ft, pm, pft_p%hydr_thetas_node(ft,pm)*cap_corr(pm), psi_node) - elseif(th_in shr_log_errMsg @@ -119,9 +119,6 @@ module FatesPlantHydraulicsMod implicit none - - - ! 1=leaf, 2=stem, 3=troot, 4=aroot ! Several of these may be better transferred to the parameter file in due time (RGK) @@ -351,12 +348,12 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ! smp) !ccohort_hydr%psi_aroot(j) = smp !ccohort_hydr%psi_aroot(j) = csite%si_hydr%psisoi_liq_innershell(j) - ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equalibrium between soil and root + ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equilibrium between soil and root - call th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%th_aroot(j)) - call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%ftc_aroot(j)) + ccohort_hydr%th_aroot(j) = th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j)) + ccohort_hydr%ftc_aroot(j) = flc_from_psi(ft, aroot_p_media, & + ccohort_hydr%th_aroot(j), & + ccohort_hydr%psi_aroot(j)) end do @@ -370,26 +367,29 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 - call th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%th_troot) - call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) + ccohort_hydr%th_troot = th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot ) + ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & + ccohort_hydr%th_troot, & + ccohort_hydr%psi_troot) !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 - call th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & - ccohort_hydr%th_ag(n_hypool_ag)) - call flc_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag), & - ccohort_hydr%ftc_ag(n_hypool_ag)) + ccohort_hydr%th_ag(n_hypool_ag) = th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag)) + ccohort_hydr%ftc_ag(n_hypool_ag) = flc_from_psi(ft, stem_p_media, & + ccohort_hydr%th_ag(n_hypool_ag), & + ccohort_hydr%psi_ag(n_hypool_ag)) do k=n_hypool_ag-1, 1, -1 dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - mpa_per_pa*denh2o*grav_earth*dz if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 - call th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), & - ccohort_hydr%th_ag(k)) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k),ccohort_hydr%ftc_ag(k)) + ccohort_hydr%th_ag(k) = th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k)) + ccohort_hydr%ftc_ag(k) = flc_from_psi(ft, porous_media(k), & + ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k)) end do ccohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 @@ -430,18 +430,24 @@ subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) ! Update Psi and FTC in above-ground compartments ! ----------------------------------------------------------------------------------- do k = 1,n_hypool_ag - call psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k), ccohort_hydr%psi_ag(k)) - call flc_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k), ccohort_hydr%ftc_ag(k)) + ccohort_hydr%psi_ag(k) = psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = flc_from_psi(ft, porous_media(k), & + ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k)) end do ! Update the Psi and FTC for the transporting root compartment - call psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot, ccohort_hydr%psi_troot) - call flc_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot, ccohort_hydr%ftc_troot) - + ccohort_hydr%psi_troot = psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot ) + ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & + ccohort_hydr%th_troot, & + ccohort_hydr%psi_troot ) + ! Update the Psi and FTC for the absorbing roots do j = 1, csite_hydr%nlevsoi_hyd - call psi_from_th(ft, aroot_p_media, ccohort_hydr%th_aroot(j), ccohort_hydr%psi_aroot(j)) - call flc_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j), ccohort_hydr%ftc_aroot(j)) + ccohort_hydr%psi_aroot(j) = psi_from_th(ft, aroot_p_media, ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = flc_from_psi(ft, aroot_p_media, & + ccohort_hydr%th_aroot(j), & + ccohort_hydr%psi_aroot(j)) end do return @@ -995,22 +1001,25 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne end if do k=1,n_hypool_ag - ccohort_hydr%psi_ag(k) = & - psi_from_th(currentCohort%pft, porous_media(k), ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = & - flc_from_psi(currentCohort%pft, porous_media(k), ccohort_hydr%psi_ag(k)) + ccohort_hydr%psi_ag(k) = psi_from_th(currentCohort%pft, porous_media(k), & + ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = flc_from_psi(currentCohort%pft, porous_media(k), & + ccohort_hydr%th_ag(k), & + ccohort_hydr%psi_ag(k)) end do - call psi_from_th(currentCohort%pft, troot_p_media, ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot) - call flc_from_psi(currentCohort%pft, troot_p_media, ccohort_hydr%psi_troot, & - ccohort_hydr%ftc_troot) + ccohort_hydr%psi_troot = psi_from_th(currentCohort%pft, troot_p_media, & + ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = flc_from_psi(currentCohort%pft, troot_p_media, & + ccohort_hydr%th_troot, & + ccohort_hydr%psi_troot) do j=1,site_hydr%nlevsoi_hyd - call psi_from_th(currentCohort%pft, aroot_p_media, ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j)) - call flc_from_psi(currentCohort%pft, aroot_p_media, ccohort_hydr%psi_aroot(j), & - ccohort_hydr%ftc_aroot(j)) + ccohort_hydr%psi_aroot(j) = psi_from_th(currentCohort%pft, aroot_p_media, & + ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = flc_from_psi(currentCohort%pft, aroot_p_media, & + ccohort_hydr%th_aroot(j), & + ccohort_hydr%psi_aroot(j)) end do ccohort_hydr%btran = flc_gs_from_psi(ccohort_hydr%psi_ag(1),currentcohort%pft) @@ -2345,12 +2354,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! potential gradient (same elevation, no geopotential ! required. - call psi_from_th(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,1), & - psi_inner_shell, & - bc_in(s)%watsat_sisl(j), & ! optional for soil - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) ! optional for soil + psi_inner_shell = psi_from_th(ccohort%pft, rhiz_p_media, & + site_hydr%h2osoi_liqvol_shell(j,1), & + bc_in(s)%watsat_sisl(j), & ! optional for soil + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) ! optional for soil ! Note, since their is no elevation difference between @@ -2363,12 +2371,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) end if ! Get matric potential [Mpa] of the absorbing root - call psi_from_th(ccohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j), psi_aroot) + psi_aroot = psi_from_th(ccohort%pft, aroot_p_media, & + ccohort_hydr%th_aroot(j)) ! Get Fraction of Total Conductivity [-] of the absorbing root - call flc_from_psi(ccohort%pft, aroot_p_media, & - psi_aroot, ftc_aroot) + ftc_aroot = flc_from_psi(ccohort%pft, aroot_p_media, & + ccohort_hydr%th_aroot(j), psi_aroot) ! Calculate total effective conductance over path [kg s-1 MPa-1] ! from absorbing root node to 1st rhizosphere shell @@ -2383,16 +2391,17 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - call psi_from_th(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,k), psi_shell, & - bc_in(s)%watsat_sisl(j), & ! optional for soil - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) + psi_shell = psi_from_th(ccohort%pft, rhiz_p_media, & + site_hydr%h2osoi_liqvol_shell(j,k), & + bc_in(s)%watsat_sisl(j), & ! optional for soil + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) - call flc_from_psi(ccohort%pft, rhiz_p_media, & - psi_shell, ftc_shell, & - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) ! optional for soil + ftc_shell = flc_from_psi(ccohort%pft, rhiz_p_media, & + site_hydr%h2osoi_liqvol_shell(j,k), & + psi_shell, & + bc_in(s)%sucsat_sisl(j), & ! optional for soil + bc_in(s)%bsw_sisl(j)) ! optional for soil r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) if(k ccohort%shorter @@ -3116,11 +3124,11 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t do inode = 1,n_hypool_tot ! Get matric potential [Mpa] - call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & - psi_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil if(psi_node(inode)>0._r8) then write(fates_log(),*) 'positive psi?' @@ -3133,20 +3141,22 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) ! Get Fraction of Total Conductivity [-] - call flc_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & - ftc_node(inode), & - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + ftc_node(inode) = flc_from_psi(cohort%pft, porous_media(inode), & + th_node(inode), & + psi_node(inode), & + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil ! deriv ftc wrt theta - call dpsidth_from_th(cohort%pft, porous_media(inode), th_node(inode), & - dpsi_dtheta_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - call dflcdpsi_from_psi(cohort%pft, porous_media(inode), psi_node(inode), & - dftc_dpsi, & + dpsi_dtheta_node(inode) = dpsidth_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil + + dftc_dpsi = dflcdpsi_from_psi(cohort%pft, porous_media(inode), & + th_node(inode), & + psi_node(inode), & bc_in%sucsat_sisl(ilayer), & ! optional for soil bc_in%bsw_sisl(ilayer)) ! optional for soil @@ -3413,11 +3423,12 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if(debug)then do inode = 1,n_hypool_tot ! Get matric potential [Mpa] - call psi_from_th(cohort%pft, porous_media(inode), th_node(inode), & - psi_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil + ! Positive psi values are def weird if(psi_node(inode) > 0._r8) then write(fates_log(),*) 'positive psi found, dumping network' @@ -3443,17 +3454,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t write(fates_log(),*) 'i theta_init theta mass' do itest = 1,n_hypool_tot ! get initial total potential of node: - call psi_from_th(cohort%pft, porous_media(itest), th_node_init(itest), & - psi_diag, & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + psi_diag = psi_from_th(cohort%pft, porous_media(itest), th_node_init(itest), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil h_diag = psi_diag + mpa_per_pa*denh2o*grav_earth*z_node(itest) write(fates_log(),*) 'node',itest,th_node_init(itest),th_node(itest),psi_node(itest),v_node(itest),h_diag,psi_diag if(itest Date: Thu, 19 Sep 2019 12:29:58 -0700 Subject: [PATCH 027/114] Fixed a constant m_per_mm and added some hydro print statements --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 30 +++- biogeophys/FatesPlantHydraulicsMod.F90 | 192 +++++++++++++++------- main/FatesConstantsMod.F90 | 4 +- main/FatesHydraulicsMemMod.F90 | 3 - 4 files changed, 155 insertions(+), 74 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 0609294f3c..f1f4fab5bc 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -37,11 +37,11 @@ module FatesHydroUnitFunctionsMod integer, parameter :: rkvol = 2 integer, parameter :: voltype = rkvol - integer, parameter :: van_genuchten = 1 - integer, parameter :: campbell = 2 - integer, parameter :: iswc = campbell + integer, public, parameter :: van_genuchten = 1 + integer, public, parameter :: campbell = 2 + integer, public, parameter :: iswc = campbell - logical, parameter :: allow_unconstrained_theta = .true. + logical, public, parameter :: allow_unconstrained_theta = .true. ! P-V curve: total RWC @ which elastic drainage begins [-] @@ -74,6 +74,10 @@ module FatesHydroUnitFunctionsMod public :: xylemtaper public :: InitAllocatePlantMedia public :: SetPlantMediaParam + public :: swcCampbell_satfrac_from_psi + public :: swcCampbell_th_from_satfrac + public :: swcCampbell_psi_from_th + contains @@ -538,7 +542,7 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) integer , intent(in) :: pm ! porous media index real(r8) , intent(in) :: th_in ! water content [m3 m-3] real(r8), optional,intent(in) :: th_sat ! water content at saturation - ! (porosity for soil) [m3 m-3] + ! (porosity for soil) [m3 m-3] real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" @@ -552,6 +556,8 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) real(r8) :: dpsidth_resid ! Change in psi wrt th @ residual WC [MPa/[m3/m3]] real(r8) :: psi_resid ! Psi at residual WC [MPa] +! write(fates_log(),*) 'in: ',pm,th_in + if(pm <= 4) then ! plant if(allow_unconstrained_theta) then @@ -573,8 +579,10 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) else if(pm == 5) then ! soil - !! NOTE. FIX: The below sidesteps the problem of averaging potentially variable soil hydraulic properties with depth - !! and simply assigns the bulk soil (bucket) approximation of hydraulic properties as equal to the top soil layer. + !! NOTE. FIX: The below sidesteps the problem of averaging + !! potentially variable soil hydraulic properties with depth + !! and simply assigns the bulk soil (bucket) approximation + !! of hydraulic properties as equal to the top soil layer. select case (iswc) case (van_genuchten) write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' @@ -588,7 +596,7 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) ! site_hydr%l_VG(1), & ! psi_node) case (campbell) - call swcCampbell_psi_from_th(th_in,th_sat, & + call swcCampbell_psi_from_th(th_in,th_sat, & -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & bsw, & psi_node) @@ -596,7 +604,11 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + + else + write(fates_log(),*) 'Invalid porous media specified in call to psi_from_th' + write(fates_log(),*) 'pm = ',pm,' ?' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end function psi_from_th diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 43fae31d3b..8c9870c96b 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -21,13 +21,6 @@ module FatesPlantHydraulicsMod ! ! ============================================================================================== - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 - ! (TODO: THE ROW WIDTH ON THIS MODULE ARE TOO LARGE. NAG COMPILERS - ! WILL FREAK IF LINES ARE TOO LONG. BEFORE SUBMITTING THIS TO - ! MASTER WE NEED TO GO THROUGH AND GET THESE LINES BELOW - ! 100 spaces (for readability), or 130 (for NAG) - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 - use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log @@ -82,10 +75,6 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: troot_p_media use FatesHydraulicsMemMod, only: aroot_p_media use FatesHydraulicsMemMod, only: rhiz_p_media - use FatesHydraulicsMemMod, only: cap_slp - use FatesHydraulicsMemMod, only: cap_int - use FatesHydraulicsMemMod, only: cap_corr - use FatesHydraulicsMemMod, only: rwcft use FatesHydraulicsMemMod, only: C2B use FatesHydraulicsMemMod, only: nlevsoi_hyd_max use FatesHydraulicsMemMod, only: cohort_recruit_water_layer @@ -98,18 +87,26 @@ module FatesPlantHydraulicsMod use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst - - use FatesPlantUnitFunctionsMod, only : Hydraulics_Tridiagonal - use FatesPlantUnitFunctionsMod, only : flc_gs_from_psi - use FatesPlantUnitFunctionsMod, only : InitAllocatePlantMedia - use FatesPlantUnitFunctionsMod, only : SetPlantMediaParam - use FatesPlantUnitFunctionsMod, only : psi_from_th - use FatesPlantUnitFunctionsMod, only : dpsidth_from_th - use FatesPlantUnitFunctionsMod, only : flc_from_psi - use FatesPlantUnitFunctionsMod, only : dflcdpsi_from_psi - use FatesPlantUnitFunctionsMod, only : swcCampbell_psi_from_th - use FatesPlantUnitFunctionsMod, only : swcCampbell_satfrac_from_psi - use FatesPlantUnitFunctionsMod, only : swcCampbell_th_from_satfrac + + use FatesHydroUnitFunctionsMod, only : Hydraulics_Tridiagonal + use FatesHydroUnitFunctionsMod, only : flc_gs_from_psi + use FatesHydroUnitFunctionsMod, only : InitAllocatePlantMedia + use FatesHydroUnitFunctionsMod, only : SetPlantMediaParam + use FatesHydroUnitFunctionsMod, only : psi_from_th + use FatesHydroUnitFunctionsMod, only : th_from_psi + use FatesHydroUnitFunctionsMod, only : dpsidth_from_th + use FatesHydroUnitFunctionsMod, only : flc_from_psi + use FatesHydroUnitFunctionsMod, only : dflcdpsi_from_psi + use FatesHydroUnitFunctionsMod, only : swcCampbell_psi_from_th + use FatesHydroUnitFunctionsMod, only : swcCampbell_satfrac_from_psi + use FatesHydroUnitFunctionsMod, only : swcCampbell_th_from_satfrac + use FatesHydroUnitFunctionsMod, only : van_genuchten + use FatesHydroUnitFunctionsMod, only : campbell + use FatesHydroUnitFunctionsMod, only : iswc + use FatesHydroUnitFunctionsMod, only : zeng2001_crootfr + use FatesHydroUnitFunctionsMod, only : xylemtaper + use FatesHydroUnitFunctionsMod, only : bisect_rootfr + use FatesHydroUnitFunctionsMod, only : shellGeom ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -147,6 +144,14 @@ module FatesPlantHydraulicsMod ! when recruitment happens? + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through + ! the plant (in 1D solves) as closed from root layer + ! to the stomata. The effect of this, is that + ! the conductances through stem and leaf surfaces + ! are reduced by the fraction of active root + ! conductance, and for each soil-layer, integration + ! proceeds over the entire time-step. + logical,parameter :: debug = .true. !flag to report warning in hydro @@ -368,7 +373,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 ccohort_hydr%th_troot = th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot ) - ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & + ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & ccohort_hydr%th_troot, & ccohort_hydr%psi_troot) @@ -1110,7 +1115,7 @@ subroutine InitHydrSites(sites,bc_in,numpft) ! P-V curve: total RWC @ which capillary reserves exhausted ! real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) - call InitAllocatePlantMedia(n_porous_media-1) + call InitAllocatePlantMedia(n_porous_media) call SetPlantMediaParam(leaf_p_media, rwcft_in=1._r8, rwccap_in=1._r8) call SetPlantMediaParam(stem_p_media, rwcft_in=0.958_r8, rwccap_in=0.947_r8) call SetPlantMediaParam(troot_p_media, rwcft_in=0.958_r8, rwccap_in=0.947_r8) @@ -2435,14 +2440,26 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) j = ordered(jj) - if(weight_serial_dt)then - dt_step = dtime*kbg_layer(j)/kbg_tot + if(do_parallel_stem) then + ! If we do "parallel" stem + ! conduits, we integrate + ! each layer over the whole time, but + ! reduce the conductance cross section + ! according to what fraction of root is active + dt_step = dtime else - dt_step = dtime/real(site_hydr%nlevsoi_hyd,r8) + if(weight_serial_dt)then + dt_step = dtime*kbg_layer(j)/kbg_tot + else + dt_step = dtime/real(site_hydr%nlevsoi_hyd,r8) + end if end if + + ! This routine will update the theta values for 1 cohort's flow-path - ! from leaf to the current soil layer + ! from leaf to the current soil layer. This does NOT + ! update cohort%th_* call ImTaylorSolve1D(ccohort,ccohort_hydr,site_hydr,bc_in(s), & j,dt_step,qflx_tran_veg_indiv, & dth_node,sapflow,rootuptake,wb_error,iter,nsteps) @@ -2539,8 +2556,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) cpatch => cpatch%younger enddo !patch - ! UPDATE THE COLUMN-LEVEL SOIL WATER CONTENT (LAYER x SHELL) + + ! In this section we evaluate the water content in the rhizosphere + ! and apply constraints, so that the water contents are not above saturation + ! or below residual. site_hydr%supsub_flag(:) = 999 + do j=1,site_hydr%nlevsoi_hyd !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter ! introduced for the van Genuchten, but does not exist for Campbell SWC. @@ -2967,6 +2988,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t integer :: i_lo ! node index on the lower (away from atm) side of current flow-path integer :: istep ! sub-step count index logical :: solution_found ! logical set to true if a solution was found within error tolerance + real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] + real(r8) :: rootfr_scaler ! Factor to scale down cross-section areas based on what + ! fraction of root is in current layer [-] real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] real(r8) :: wb_step_err ! water balance error over substep [kg] @@ -3005,9 +3029,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps ! by this much - integer, parameter :: max_iter = 5 ! Maximum number of iterations with which we reduce timestep - real(r8), parameter :: max_wb_step_err = 1.e-6_r8 - real(r8), parameter :: max_wb_err = 1.e-4_r8 ! threshold for water balance error (stop model) [mm h2o] + integer, parameter :: max_iter = 10 ! Maximum number of iterations with which we reduce timestep + real(r8), parameter :: max_wb_step_err = 1.e-7_r8 + real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [mm h2o] logical, parameter :: no_ftc_radialk = .false. @@ -3030,6 +3054,31 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + + + + ! If in "spatially parallel" mode, scale down cross section + ! of flux through top by the root fraction of this layer + + if(do_parallel_stem)then + ! Determine the root fraction that is in this layer + roota=EDPftvarcon_inst%roota_par(cohort%pft) + rootb=EDPftvarcon_inst%rootb_par(cohort%pft) + if(ilayer==1) then + rootfr_scaler = zeng2001_crootfr(roota,rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + else + rootfr_scaler = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer-1), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + end if + if(rootfr_scaler < 0.0000001_r8) then + print*,"REALLY SMALL ROOTFR?",rootfr_scaler + stop + end if + else + rootfr_scaler = 1.0_r8 + end if + + q_top_eff = q_top * rootfr_scaler ! For all nodes leaf through rhizosphere ! Send node heights and compartment volumes to a node-based array @@ -3058,7 +3107,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do - ! Outer iteration loop ! This cuts timestep in half and resolve the solution with smaller substeps ! This loop is cleared when the model has found a solution @@ -3086,6 +3134,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o root_water = ((cohort_hydr%th_troot*cohort_hydr%v_troot) + & sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o + write(fates_log(),*) 'flux: ', q_top_eff*dt_substep + write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' write(fates_log(),*) 'root_water: ',root_water,' kg/plant' @@ -3124,12 +3174,12 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t do inode = 1,n_hypool_tot ! Get matric potential [Mpa] - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil + if(psi_node(inode)>0._r8) then write(fates_log(),*) 'positive psi?' write(fates_log(),*) inode,ilayer,psi_node(inode),th_node(inode),th_node_init(inode) @@ -3187,8 +3237,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t jpath = 1 i_up = 1 i_lo = 2 - kmax_up = cohort_hydr%kmax_petiole_to_leaf - kmax_lo = cohort_hydr%kmax_stem_upper(1) + kmax_up = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf + kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) call GetImTaylorKAB(kmax_lo,kmax_up, & ftc_node(i_lo),ftc_node(i_up), & @@ -3207,13 +3257,16 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t i_up = jpath i_lo = jpath+1 - ! This compartment is the "upper" node, but uses + + + ! "Up" compartment is the "upper" node, but uses ! the "lower" side of its compartment for the calculation. ! Ultimately, it is more "upper" than its counterpart - kmax_up = cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) ! This compartment is the "lower" node, but uses ! the "higher" side of its compartment. - kmax_lo = cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) + + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) call GetImTaylorKAB(kmax_lo,kmax_up, & ftc_node(i_lo),ftc_node(i_up), & @@ -3232,8 +3285,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t jpath = n_hypool_ag i_up = jpath i_lo = jpath+1 - kmax_up = cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_lo = cohort_hydr%kmax_troot_upper + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper call GetImTaylorKAB(kmax_lo,kmax_up, & ftc_node(i_lo),ftc_node(i_up), & @@ -3247,6 +3300,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Path is between the transporting root ! and the absorbing root for this layer + ! NOTE: No need to scale by root fraction + ! even if in parallel mode, already parallel! jpath = n_hypool_ag+1 i_up = jpath @@ -3323,7 +3378,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t tris_a(1) = 0._r8 tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep tris_c(1) = B_term(1) - tris_r(1) = q_top - k_eff(1)*(h_node(2)-h_node(1)) + tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) do inode = 2,n_hypool_tot-1 @@ -3349,13 +3404,17 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) - ! Catch super-saturated and sub-residual water contents + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator + + th_node(:) = th_node(:) + dth_node(:) ! Mass error (flux - change) ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_end = sum((th_node(:)+dth_node(:))*v_node(:))*denh2o - - wb_step_err = (q_top*dt_substep) - (w_tot_beg-w_tot_end) + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) if(abs(wb_step_err)>max_wb_step_err)then solution_found = .false. @@ -3367,11 +3426,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t solution_found = .true. end if - ! If we have not broken from the substep loop, - ! that means this sub-step has been acceptable, and we may - ! go ahead and update the water content for the integrator - - th_node(:) = th_node(:) + dth_node(:) ! Accumulate the water balance error for diagnostic purposes wb_err = wb_err + wb_step_err @@ -3422,9 +3476,27 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Do some checks on weird values. if(debug)then do inode = 1,n_hypool_tot + ! Get matric potential [Mpa] + !if(ilayer==20) write(fates_log(),*) ilayer,inode,cohort%pft,th_node(inode),bc_in%watsat_sisl(ilayer) + + if(porous_media(inode)<5) then + if( (th_node(inode) > EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode))) .or. & + (th_node(inode) < EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode)))) then + print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode), & + EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode), & + EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode) + end if + else + if( (th_node(inode) > bc_in%watsat_sisl(ilayer) ) .or. & + (th_node(inode) < 0.95*bc_in%eff_porosity_sl(ilayer))) then + print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode),bc_in%watsat_sisl(ilayer) + end if + end if + + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & + th_node(inode), & bc_in%watsat_sisl(ilayer), & ! optional for soil bc_in%sucsat_sisl(ilayer), & ! optional for soil bc_in%bsw_sisl(ilayer)) ! optional for soil @@ -3435,7 +3507,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t write(fates_log(),*) 'dbh: ',cohort%dbh write(fates_log(),*) 'pft: ',cohort%pft write(fates_log(),*) 'soil layer:',ilayer - write(fates_log(),*) 'qtop [kg]:',q_top*dt_step + write(fates_log(),*) 'qtop [kg]:',q_top_eff*dt_step write(fates_log(),*) 'q patch: ',bc_in%qflx_transp_pa(:) write(fates_log(),*) 'g_sb_laweight: ',cohort%g_sb_laweight write(fates_log(),*) 'lai: ',cohort%treelai @@ -3481,7 +3553,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if ( abs(wb_err) > max_wb_err ) then write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dt_step*q_top,' kg/step/plant' + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 8ab0c40a77..6b9134083a 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -89,10 +89,10 @@ module FatesConstantsMod real(fates_r8), parameter, public :: umol_per_kmol = 1.0E9_fates_r8 ! Conversion factor: meters per milimeter - real(fates_r8), parameter, public :: m_per_mm = 1.0E-6_fates_r8 + real(fates_r8), parameter, public :: m_per_mm = 1.0E-3_fates_r8 ! Conversion factor: milimeters per meter - real(fates_r8), parameter, public :: mm_per_m = 1.0E6_fates_r8 + real(fates_r8), parameter, public :: mm_per_m = 1.0E3_fates_r8 ! Conversion factor: m2 per ha real(fates_r8), parameter, public :: m2_per_ha = 1.0e4_fates_r8 diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 64fc457eaa..eb3d207bf1 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -299,9 +299,6 @@ module FatesHydraulicsMemMod end type ed_cohort_hydr_type - ! Make public necessary subroutines and functions - public :: InitHydraulicsDerived - contains subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) From e023ac2991e9afa638df99151f3157ef9094db26 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 20 Sep 2019 10:41:51 -0700 Subject: [PATCH 028/114] Expanding unit tests in hydro to rhizosphere. Extending rhizosphere pedotransfer functions to handle unconstrained regimes. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 48 ++++++++++-- biogeophys/FatesPlantHydraulicsMod.F90 | 24 +++--- .../hydro/HydroUTestDriver.py | 75 +++++++++++++++++-- 3 files changed, 123 insertions(+), 24 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index f1f4fab5bc..84bb32095a 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -43,6 +43,9 @@ module FatesHydroUnitFunctionsMod logical, public, parameter :: allow_unconstrained_theta = .true. + real(r8), parameter :: min_rhiz_psi = -20._r8 ! Minimum allowable rhizosphere + ! matric potential [MPa] + ! P-V curve: total RWC @ which elastic drainage begins [-] real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) @@ -549,12 +552,13 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) ! ! !LOCAL VARIABLES: real(r8) :: satfrac ! saturation fraction [0-1] - + real(r8) :: suc_sat_mpa ! Suction at saturation in [MPa] ! Result real(r8) :: psi_node ! water potential [MPa] real(r8) :: dpsidth_resid ! Change in psi wrt th @ residual WC [MPa/[m3/m3]] real(r8) :: psi_resid ! Psi at residual WC [MPa] + real(r8) :: th_min ! water content at lowest allowable potential(soil) ! write(fates_log(),*) 'in: ',pm,th_in @@ -596,10 +600,22 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) ! site_hydr%l_VG(1), & ! psi_node) case (campbell) - call swcCampbell_psi_from_th(th_in,th_sat, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - psi_node) + suc_sat_mpa = -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa + th_min = th_sat*(min_rhiz_psi/suc_sat_mpa)**(-1._r8/bsw) + + ! Constrain psi so that it can't go lower than -20MPa + psi_node = suc_sat_mpa * (max(th_in,th_min)/th_sat)**(-bsw) + +! th_in/th_sat = (psi_node/suc_sat_mpa)**(-1/bsw) +! psi_node/suc_sat_mpa = (th_in/th_sat)**(-bsw) +! psi_node = suc_sat_mpa*(th_in/th_sat)**(-bsw) + + +! call swcCampbell_psi_from_th(th_in, & +! th_sat, & +! -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & +! bsw, & +! psi_node) case default write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1595,10 +1611,28 @@ subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) ! ! !LOCAL VARIABLES: real(r8) :: satfrac !saturation fraction [0-1] + real(r8) :: th_min ! minimum allowable theta !------------------------------------------------------------------------------ - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) +! call swcCampbell_satfrac_from_th(th, watsat, satfrac) +! call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) + + + + th_min = watsat*(min_rhiz_psi/psisat)**(-1._r8/B) + + ! Constrain psi so that it can't go lower than -20MPa + if(th<=th_min) then + dpsidth = 0._r8 + else + dpsidth = -B * psisat * (1._r8/watsat) * (th/watsat)**(-B-1.0_r8) + end if + +! th_in/th_sat = (psi_node/suc_sat_mpa)**(-1/bsw) +! psi_node/suc_sat_mpa = (th_in/th_sat)**(-bsw) +! psi_node = suc_sat_mpa*(th_in/th_sat)**(-bsw) + + end subroutine swcCampbell_dpsidth_from_th diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 8c9870c96b..730b7e4bab 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -370,7 +370,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) dz = ccohort_hydr%z_node_troot - bc_in%z_sisl(1) - ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - 1.e-6_r8*denh2o*grav_earth*dz + ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - mpa_per_pa*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 ccohort_hydr%th_troot = th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot ) ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & @@ -380,7 +380,7 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot - ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - 1.e-6_r8*denh2o*grav_earth*dz + ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - mpa_per_pa*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 ccohort_hydr%th_ag(n_hypool_ag) = th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag)) ccohort_hydr%ftc_ag(n_hypool_ag) = flc_from_psi(ft, stem_p_media, & @@ -1187,7 +1187,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) ! Calculate the matric potential on the innner shell (this is used to initialize ! xylem and root pressures in new cohorts) call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & + bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm, & bc_in(s)%bsw_sisl(j), smp) site_hydr%psisoi_liq_innershell(j) = smp @@ -2217,7 +2217,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%errh2o_hyd = 0._r8 prev_h2oveg = site_hydr%h2oveg - + print*,"---------------------------" + print*,bc_in(s)%watsat_sisl(:) + print*,bc_in(s)%sucsat_sisl(:) + print*,bc_in(s)%bsw_sisl(:) + ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- transp_flux = 0._r8 @@ -3053,8 +3057,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! site_hydr%l_aroot_layer(ilayer) is units [m/site] aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) - - ! If in "spatially parallel" mode, scale down cross section @@ -3472,6 +3474,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do + ! Do some checks on weird values. if(debug)then @@ -3483,17 +3486,16 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if(porous_media(inode)<5) then if( (th_node(inode) > EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode))) .or. & (th_node(inode) < EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode)))) then - print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode), & - EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode), & - EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode) + !!print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode), & + !! EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode)), & + !! EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode)) end if else if( (th_node(inode) > bc_in%watsat_sisl(ilayer) ) .or. & (th_node(inode) < 0.95*bc_in%eff_porosity_sl(ilayer))) then - print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode),bc_in%watsat_sisl(ilayer) + !!print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode),bc_in%watsat_sisl(ilayer),bc_in%sucsat_sisl(ilayer),bc_in%bsw_sisl(ilayer) end if end if - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & th_node(inode), & diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index a02b8f7f90..c8eeaf276e 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -67,8 +67,14 @@ pm_stem = 2 pm_troot = 3 pm_aroot = 4 +pm_rhiz = 5 -unconstrained = True +# Constants for rhizosphere +watsat = [0.567, 0.444] +sucsat = [159.659, 256.094] +bsw = [6.408, 9.27] + +unconstrained = False # ======================================================================================== @@ -235,6 +241,7 @@ def main(argv): min_aroot_theta2 = pftparms['hydr_resid_node'].data[pm_aroot-1,pft2-1] + # Initialize Theta leaf_theta = np.linspace(min_leaf_theta,max_leaf_theta, num=npts) stem_theta = np.linspace(min_stem_theta,max_stem_theta, num=npts) @@ -242,14 +249,12 @@ def main(argv): aroot_theta = np.linspace(min_aroot_theta,max_aroot_theta, num=npts) leaf_theta2 = np.linspace(min_leaf_theta2,max_leaf_theta, num=npts) - # Initialize PSI leaf_psi = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) leaf_psi2 = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) - stem_psi = np.zeros(shape=np.shape(stem_theta),dtype=np.float64) - troot_psi = np.zeros(shape=np.shape(troot_theta),dtype=np.float64) - aroot_psi = np.zeros(shape=np.shape(aroot_theta),dtype=np.float64) - + stem_psi = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) + troot_psi = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) + aroot_psi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) # Initialize dPSI/dtheta derivative and discrete check leaf_dpsidth = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) @@ -261,6 +266,7 @@ def main(argv): aroot_dpsidth = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) aroot_dpsidthc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + # Initialize the FLC and its derivative leaf_flc = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) leaf_dflcdpsi = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) @@ -278,6 +284,8 @@ def main(argv): aroot_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) aroot_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) + + mpl.rcParams.update({'font.size': 15}) @@ -444,6 +452,61 @@ def main(argv): plt.tight_layout() + # Rhizosphere + # ----------------------------------------------------------------------------------- + + min_rhiz_theta = 0.01 + max_rhiz_theta = 0.99 #watsat[0] + rhiz_theta = np.linspace(min_rhiz_theta,max_rhiz_theta, num=npts) + rhiz_psi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_psi2 = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dpsidth = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dpsidthc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_flc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dflcdpsi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dflcdpsic = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + + for i,th in enumerate(rhiz_theta): + rhiz_psi[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) + rhiz_psi2[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), c8(watsat[1]), c8(sucsat[1]), c8(bsw[1])) + + fig5, (ax1,ax2) = plt.subplots(2) + ax1.plot(rhiz_theta,rhiz_psi,label='Sat={}, PSIsat={}, B={}'.format(watsat[0],-sucsat[0]*9.8*1.e-9*1000.0 ,bsw[0])) + ax1.plot(rhiz_theta,rhiz_psi2,label='Sat={}, PSIsat={}, B={}'.format(watsat[1],-sucsat[1]*9.8*1.e-9*1000.0 ,bsw[1])) + ax1.grid(True) + ax1.set_ylabel('Psi [MPa]') + ax1.set_xlim((0,1)) + ax1.set_xlabel('Theta [m3/m3]') + ax1.set_title('Rhizosphere') + ax1.legend(loc='lower right') + plt.tight_layout() + + ax2.plot(leaf_theta,leaf_psi,label='Leaf') + ax2.plot(stem_theta,stem_psi,label='Stem') + ax2.plot(troot_theta,troot_psi,label='Troot') + ax2.plot(aroot_theta,aroot_psi,label='Aroot') + ax2.grid(True) + ax2.set_ylabel('Psi [MPa]') + ax2.set_xlim((0,1)) + ax2.set_xlabel('Theta [m3/m3]') + ax2.set_title('PFT: {}'.format(pft1)) + ax2.legend(loc='lower right') + plt.tight_layout() + + + # back-calculate the derivative + for i in range(1,len(rhiz_psi)-1): + rhiz_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]),c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) + rhiz_dpsidthc[i] = (rhiz_psi[i+1]-rhiz_psi[i-1])/(rhiz_theta[i+1]-rhiz_theta[i-1]) + + fig6, ax1 = plt.subplots(1) + ax1.plot(rhiz_psi,rhiz_dpsidth,label='function') + ax1.plot(rhiz_psi,rhiz_dpsidthc,label='discrete') + ax1.legend(loc='upper left') + ax1.set_ylabel('dPsi/dth') + ax1.set_title('Rhizosphere') + ax1.grid(True) + plt.show() # code.interact(local=dict(globals(), **locals())) From 600b7d8b4127f3c69915096da7c9cab5d7e45aab Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 23 Sep 2019 11:09:12 -0700 Subject: [PATCH 029/114] Added code to enable operation beyond the residual wcs in plants, should also make provisions for soil. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 137 +++++++++++---- biogeophys/FatesPlantHydraulicsMod.F90 | 9 +- .../hydro/HydroUTestDriver.py | 163 +++++++++++++----- 3 files changed, 224 insertions(+), 85 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 84bb32095a..9d166ff96d 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -46,6 +46,15 @@ module FatesHydroUnitFunctionsMod real(r8), parameter :: min_rhiz_psi = -20._r8 ! Minimum allowable rhizosphere ! matric potential [MPa] + real(r8), parameter :: max_dpsidth = 1000._r8 ! Some of these functions have + ! very stiff derivatives, so we cap + ! the psi to theta pedotransfer + ! functions so they can not + ! exceed this value on the residual + ! side of the theta. Ultimately + ! this is used to calculate a + ! lower theta bound + ! P-V curve: total RWC @ which elastic drainage begins [-] real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) @@ -552,15 +561,14 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) ! ! !LOCAL VARIABLES: real(r8) :: satfrac ! saturation fraction [0-1] - real(r8) :: suc_sat_mpa ! Suction at saturation in [MPa] - - ! Result - real(r8) :: psi_node ! water potential [MPa] + + real(r8) :: psi_node ! water potential [MPa] real(r8) :: dpsidth_resid ! Change in psi wrt th @ residual WC [MPa/[m3/m3]] real(r8) :: psi_resid ! Psi at residual WC [MPa] - real(r8) :: th_min ! water content at lowest allowable potential(soil) - -! write(fates_log(),*) 'in: ',pm,th_in + real(r8) :: th_cap ! water content at lowest allowable before we + ! cap the derivative + real(r8) :: dthdpsi_cap ! derivative at th_cap (for extrapolation) + real(r8) :: suc_sat_mpa ! Suction at saturation in [MPa] if(pm <= 4) then ! plant @@ -600,22 +608,21 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) ! site_hydr%l_VG(1), & ! psi_node) case (campbell) + suc_sat_mpa = -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa - th_min = th_sat*(min_rhiz_psi/suc_sat_mpa)**(-1._r8/bsw) - - ! Constrain psi so that it can't go lower than -20MPa - psi_node = suc_sat_mpa * (max(th_in,th_min)/th_sat)**(-bsw) -! th_in/th_sat = (psi_node/suc_sat_mpa)**(-1/bsw) -! psi_node/suc_sat_mpa = (th_in/th_sat)**(-bsw) -! psi_node = suc_sat_mpa*(th_in/th_sat)**(-bsw) + th_cap = swcCampbell_th_from_dpsidth(th_sat, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw) + if(th_in>th_sat) then + psi_node = suc_sat_mpa + elseif(th_in1.0_r8)then + print*,psi,psisat,B,flc + stop + end if + end subroutine unsatkCampbell_flc_from_psi @@ -1815,7 +1871,22 @@ subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] !------------------------------------------------------------------------------ - dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) + + !flc = max(1._r8,psi/psisat)**(-2._r8-3._r8/B) + + ! FLC is well behaved at very very low values of psi (asymptotic) + ! Although, it is not well behaved at very high values, which + ! has a cap, and thus derivative of zero + if(psi>psisat) then + dflcdpsi = 0._r8 + else + !dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) + dflcdpsi = (1._r8/psisat)*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) + end if + + ! flc = max(1._r8,psi/psisat)**(-2._r8-3._r8/B) + + ! (psi/psisat)**(-2._r8-3._r8/B-1._r8)*(1./psisat)*(-2._r8-2._r8/B) end subroutine unsatkCampbell_dflcdpsi_from_psi diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 730b7e4bab..fa3dd8cf0e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2589,15 +2589,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) (bc_in(s)%watsat_sisl(j)-small_theta_num)) then site_hydr%supsub_flag(j) = k site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num - print*,"SUPERSATURATED" - stop - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & (watres_local+small_theta_num)) then site_hydr%supsub_flag(j) = -k site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num - print*,"SUBRESIDUAL" - stop else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & dth_layershell_col(j,k) @@ -2636,7 +2631,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - delta_soil_storage - if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-9_r8 ) then + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-6_r8 ) then write(fates_log(),*) 'Site plant water balance does not close' write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' @@ -2645,7 +2640,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(abs(delta_soil_storage + root_flux) > 1.e-9_r8 ) then + if(abs(delta_soil_storage + root_flux) > 1.e-6_r8 ) then write(fates_log(),*) 'Site soil water balance does not close' write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index c8eeaf276e..bc28ffc1bd 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -69,12 +69,15 @@ pm_aroot = 4 pm_rhiz = 5 +isoil1 = 0 # Top soil layer parameters (@BCI) +isoil2 = 1 # Bottom soil layer parameters + # Constants for rhizosphere watsat = [0.567, 0.444] sucsat = [159.659, 256.094] bsw = [6.408, 9.27] -unconstrained = False +unconstrained = True # ======================================================================================== @@ -226,6 +229,8 @@ def main(argv): min_stem_theta2 = 0.01 min_troot_theta2 = 0.01 min_aroot_theta2 = 0.01 + min_rhiz_theta = 0.01 + max_rhiz_theta = 0.99 else: min_leaf_theta = pftparms['hydr_resid_node'].data[pm_leaf-1,pft1-1] max_leaf_theta = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft1-1] @@ -239,6 +244,20 @@ def main(argv): min_stem_theta2 = pftparms['hydr_resid_node'].data[pm_stem-1,pft2-1] min_troot_theta2 = pftparms['hydr_resid_node'].data[pm_troot-1,pft2-1] min_aroot_theta2 = pftparms['hydr_resid_node'].data[pm_aroot-1,pft2-1] + min_rhiz_theta = 0.01 + max_rhiz_theta = watsat[isoil1] + + # Rhizosphere + # ----------------------------------------------------------------------------------- + + rhiz_theta = np.linspace(min_rhiz_theta,max_rhiz_theta, num=npts) + rhiz_psi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_psi2 = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dpsidth = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dpsidthc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_flc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dflcdpsi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) + rhiz_dflcdpsic = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) @@ -309,19 +328,37 @@ def main(argv): for i,th in enumerate(aroot_theta): aroot_psi[i] = psi_from_th(ci(pft1), ci(pm_aroot), c8(th)) + for i,th in enumerate(rhiz_theta): + rhiz_psi[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), \ + c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) + rhiz_psi2[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), \ + c8(watsat[1]), c8(sucsat[1]), c8(bsw[1])) - fig0, ax1 = plt.subplots(1) + fig0, (ax1,ax2) = plt.subplots(1,2,figsize=(9,6)) ax1.plot(leaf_theta,leaf_psi,label='Leaf') ax1.plot(stem_theta,stem_psi,label='Stem') ax1.plot(troot_theta,troot_psi,label='Troot') ax1.plot(aroot_theta,aroot_psi,label='Aroot') + ax1.plot(rhiz_theta,rhiz_psi,label='Rhiz') ax1.grid(True) ax1.set_ylabel('Psi') ax1.set_xlim((0,1)) + ax1.set_ylim((-20,0)) ax1.set_xlabel('Theta') ax1.set_title('PFT: {}'.format(pft1)) ax1.legend(loc='lower right') + ax2.plot(leaf_theta,semilogneg(leaf_psi),label='Leaf') + ax2.plot(stem_theta,semilogneg(stem_psi),label='Stem') + ax2.plot(troot_theta,semilogneg(troot_psi),label='Troot') + ax2.plot(aroot_theta,semilogneg(aroot_psi),label='Aroot') + ax2.plot(rhiz_theta,semilogneg(rhiz_psi),label='Rhiz') + ax2.grid(True) + ax2.set_ylabel('log(Psi)') + ax2.set_xlim((0,1)) + ax2.set_xlabel('Theta') + + plt.tight_layout() @@ -343,12 +380,19 @@ def main(argv): aroot_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_aroot), c8(aroot_theta[i])) aroot_dpsidthc[i] = (aroot_psi[i+1]-aroot_psi[i-1])/(aroot_theta[i+1]-aroot_theta[i-1]) + for i in range(1,len(rhiz_theta)-1): + rhiz_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_rhiz), \ + c8(rhiz_theta[i]), c8(watsat[0]), \ + c8(sucsat[0]), c8(bsw[0])) + rhiz_dpsidthc[i] = (rhiz_psi[i+1]-rhiz_psi[i-1])/ \ + (rhiz_theta[i+1]-rhiz_theta[i-1]) - fig2, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(9,7)) + + fig2, ((ax1,ax2),(ax3,ax4),(ax5,ax6)) = plt.subplots(3,2,figsize=(9,11)) ax1.plot(leaf_theta,leaf_dpsidth,label='function') ax1.plot(leaf_theta,leaf_dpsidthc,label='discrete') ax1.set_xlim((0,1)) - ax1.legend(loc='lower left') + ax1.legend(loc='upper right') ax1.set_title('Leaf') ax1.set_ylabel('dpsi/dth') ax1.grid(True) @@ -356,21 +400,28 @@ def main(argv): ax2.plot(stem_theta,stem_dpsidthc) ax2.set_xlim((0,1)) ax2.set_title('Stem') - ax2.legend(loc='lower left') ax2.grid(True) - ax3.plot(troot_theta,troot_dpsidth,label='dpsidth') - ax3.plot(troot_theta,troot_dpsidthc,label='DPsi/Dtheta') + ax3.plot(troot_theta,troot_dpsidth) + ax3.plot(troot_theta,troot_dpsidthc) ax3.set_xlim((0,1)) ax3.set_title('TRoot') ax3.set_ylabel('dpsi/dth') - ax3.set_xlabel('theta') ax3.grid(True) - ax4.plot(aroot_theta,aroot_dpsidth,label='dpsidth') - ax4.plot(aroot_theta,aroot_dpsidthc,label='DPsi/Dtheta') + ax4.plot(aroot_theta,aroot_dpsidth) + ax4.plot(aroot_theta,aroot_dpsidthc) ax4.set_xlim((0,1)) ax4.set_title('ARoot') ax4.set_xlabel('theta') ax4.grid(True) + ax5.plot(rhiz_theta,rhiz_dpsidth) + ax5.plot(rhiz_theta,rhiz_dpsidthc) + ax5.set_xlim((0,1)) + ax5.set_title('Rhiz') + ax5.set_xlabel('theta') + ax5.set_ylabel('dpsi/dth') + ax5.grid(True) + ax6.axis('off') + plt.tight_layout() # Plot out FTC/PSI @@ -391,6 +442,10 @@ def main(argv): for i,psi in enumerate(aroot_psi): aroot_flc[i] = flc_from_psi(ci(pft1), ci(pm_aroot), c8(aroot_theta[i]), c8(psi)) + for i,psi in enumerate(rhiz_psi): + rhiz_flc[i] = flc_from_psi(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]), \ + c8(psi), c8(sucsat[isoil1]), c8(bsw[isoil1])) + # back-calculate the derivative for i in range(1,len(leaf_psi)-1): @@ -408,30 +463,43 @@ def main(argv): troot_dflcdpsic[i] = (troot_flc[i+1]-troot_flc[i-1]) / \ (troot_psi[i+1]-troot_psi[i-1]) - for i in range(1,len(aroot_psi)-1): aroot_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_aroot), c8(aroot_theta[i]), c8(aroot_psi[i])) aroot_dflcdpsic[i] = (aroot_flc[i+1]-aroot_flc[i-1]) / \ (aroot_psi[i+1]-aroot_psi[i-1]) - fig3, ax1 = plt.subplots(1) + for i in range(1,len(rhiz_psi)-1): + rhiz_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]), \ + c8(rhiz_psi[i]), c8(sucsat[0]), c8(bsw[0])) + rhiz_dflcdpsic[i] = (rhiz_flc[i+1] - rhiz_flc[i-1])/(rhiz_psi[i+1]-rhiz_psi[i-1]) + + + fig3, (ax1,ax2) = plt.subplots(1,2,figsize=(9,6)) ax1.plot(leaf_psi,leaf_flc,label='Leaf') ax1.plot(stem_psi,stem_flc,label='Stem') ax1.plot(troot_psi,troot_flc,label='Troot') ax1.plot(aroot_psi,aroot_flc,label='Aroot') + ax1.plot(rhiz_psi,rhiz_flc,label='Rhiz') ax1.grid(True) - ax1.set_ylabel('FTC') - ax1.set_xlabel('Psi') + ax1.set_ylabel('FTC [-]') + ax1.set_xlabel('Psi [MPa]') ax1.legend(loc='upper left') ax1.set_title('PFT: {}'.format(pft1)) + ax2.plot(leaf_theta,leaf_flc,label='leaf') + ax2.plot(stem_theta,stem_flc,label='stem') + ax2.plot(troot_theta,troot_flc,label='troot') + ax2.plot(aroot_theta,aroot_flc,label='aroot') + ax2.plot(rhiz_theta,rhiz_flc,label='rhiz') + ax2.grid(True) + ax2.set_ylabel('FTC [-]') + ax2.set_xlabel('Theta [m3/m3]') plt.tight_layout() - - fig4, ((ax1,ax2),(ax3,ax4)) = plt.subplots(2,2,figsize=(9,7)) + fig4, ((ax1,ax2),(ax3,ax4),(ax5,ax6)) = plt.subplots(3,2,figsize=(9,11)) ax1.plot(leaf_psi,leaf_dflcdpsi,label='function') ax1.plot(leaf_psi,leaf_dflcdpsic,label='discrete') ax1.legend(loc='upper left') - ax1.set_ylabel('dFLC/dPSI') + ax1.set_ylabel('dFLC/dPsi') ax1.set_title('Leaf') ax1.grid(True) ax2.plot(stem_psi,stem_dflcdpsi) @@ -441,34 +509,36 @@ def main(argv): ax3.plot(leaf_psi,leaf_dflcdpsi) ax3.plot(leaf_psi,leaf_dflcdpsic) ax3.set_title('TRoot') - ax3.set_xlabel('Psi') - ax3.set_ylabel('dFLC/dPSI') + ax3.set_ylabel('dFLC/dPsi') ax3.grid(True) ax4.plot(leaf_psi,leaf_dflcdpsi) ax4.plot(leaf_psi,leaf_dflcdpsic) ax4.set_title('ARoot') ax4.set_xlabel('Psi') ax4.grid(True) + ax5.plot(rhiz_psi,semilogneg(rhiz_dflcdpsi)) + ax5.plot(rhiz_psi,semilogneg(rhiz_dflcdpsic)) + ax5.set_title('Rhiz') + ax5.set_xlabel('Psi') + ax5.set_ylabel('log(dFLC/dPsi)') + ax5.grid(True) + ax6.axis('off') plt.tight_layout() - # Rhizosphere - # ----------------------------------------------------------------------------------- + fig44, ax1 = plt.subplots(1,figsize=(7,7)) + ax1.plot(leaf_theta,leaf_dflcdpsi*leaf_dpsidth,label='leaf') + ax1.plot(stem_theta,stem_dflcdpsi*stem_dpsidth,label='stem') + ax1.plot(troot_theta,troot_dflcdpsi*troot_dpsidth,label='troot') + ax1.plot(aroot_theta,aroot_dflcdpsi*aroot_dpsidth,label='aroot') + ax1.plot(rhiz_theta,rhiz_dflcdpsi*rhiz_dpsidth,label='rhiz') + ax1.legend(loc='upper left') + ax1.set_ylabel('dFLC/dtheta') + ax1.set_xlabel('theta') + ax1.grid(True) + plt.tight_layout() - min_rhiz_theta = 0.01 - max_rhiz_theta = 0.99 #watsat[0] - rhiz_theta = np.linspace(min_rhiz_theta,max_rhiz_theta, num=npts) - rhiz_psi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_psi2 = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dpsidth = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dpsidthc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_flc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dflcdpsi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dflcdpsic = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - for i,th in enumerate(rhiz_theta): - rhiz_psi[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) - rhiz_psi2[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), c8(watsat[1]), c8(sucsat[1]), c8(bsw[1])) fig5, (ax1,ax2) = plt.subplots(2) ax1.plot(rhiz_theta,rhiz_psi,label='Sat={}, PSIsat={}, B={}'.format(watsat[0],-sucsat[0]*9.8*1.e-9*1000.0 ,bsw[0])) @@ -494,23 +564,26 @@ def main(argv): plt.tight_layout() - # back-calculate the derivative - for i in range(1,len(rhiz_psi)-1): - rhiz_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]),c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) - rhiz_dpsidthc[i] = (rhiz_psi[i+1]-rhiz_psi[i-1])/(rhiz_theta[i+1]-rhiz_theta[i-1]) - fig6, ax1 = plt.subplots(1) - ax1.plot(rhiz_psi,rhiz_dpsidth,label='function') - ax1.plot(rhiz_psi,rhiz_dpsidthc,label='discrete') - ax1.legend(loc='upper left') - ax1.set_ylabel('dPsi/dth') - ax1.set_title('Rhizosphere') - ax1.grid(True) + plt.show() # code.interact(local=dict(globals(), **locals())) +# Helper code to plot negative logs + +def semilogneg(x): + + y = np.sign(x)*np.log(abs(x)) + return(y) + +def semilog10net(x): + + y = np.sign(x)*np.log10(abs(x)) + return(y) + + # ======================================================================================= # This is the actual call to main From d624f2c3853c3f7a63bc5c8bff19d6c85e721ded Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 23 Sep 2019 14:59:07 -0700 Subject: [PATCH 030/114] hydro diagnostics --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 3 +- biogeophys/FatesPlantHydraulicsMod.F90 | 82 +++++++++++++++++------ 2 files changed, 62 insertions(+), 23 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 9d166ff96d..c8879ce624 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -46,7 +46,7 @@ module FatesHydroUnitFunctionsMod real(r8), parameter :: min_rhiz_psi = -20._r8 ! Minimum allowable rhizosphere ! matric potential [MPa] - real(r8), parameter :: max_dpsidth = 1000._r8 ! Some of these functions have + real(r8), parameter :: max_dpsidth = 2000._r8 ! Some of these functions have ! very stiff derivatives, so we cap ! the psi to theta pedotransfer ! functions so they can not @@ -54,6 +54,7 @@ module FatesHydroUnitFunctionsMod ! side of the theta. Ultimately ! this is used to calculate a ! lower theta bound + ! [MPa/ m3/m3] ! P-V curve: total RWC @ which elastic drainage begins [-] diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index fa3dd8cf0e..9d0cc7b736 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2177,6 +2177,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: transp_flux real(r8) :: delta_plant_storage real(r8) :: delta_soil_storage + real(r8) :: mean_theta ! mean water content per soil layer (testing) [m3/m3] type(ed_site_hydr_type), pointer :: site_hydr type(ed_cohort_hydr_type), pointer :: ccohort_hydr @@ -2217,11 +2218,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%errh2o_hyd = 0._r8 prev_h2oveg = site_hydr%h2oveg - print*,"---------------------------" - print*,bc_in(s)%watsat_sisl(:) - print*,bc_in(s)%sucsat_sisl(:) - print*,bc_in(s)%bsw_sisl(:) - ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- transp_flux = 0._r8 @@ -2283,10 +2279,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) write(fates_log(),*) 'gscan_patch: ',gscan_patch call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - write(fates_log(),*) 'q patch: ',bc_in(s)%qflx_transp_pa(ifp) - ccohort=>cpatch%tallest do while(associated(ccohort)) @@ -2564,8 +2557,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! In this section we evaluate the water content in the rhizosphere ! and apply constraints, so that the water contents are not above saturation ! or below residual. - site_hydr%supsub_flag(:) = 999 + site_hydr%supsub_flag(:) = 999 do j=1,site_hydr%nlevsoi_hyd !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter ! introduced for the van Genuchten, but does not exist for Campbell SWC. @@ -2585,20 +2578,40 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) case default end select do k=1,nshell - if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & - (bc_in(s)%watsat_sisl(j)-small_theta_num)) then - site_hydr%supsub_flag(j) = k - site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & - (watres_local+small_theta_num)) then - site_hydr%supsub_flag(j) = -k - site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num - else +!! if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & +!! (bc_in(s)%watsat_sisl(j)-small_theta_num)) then +!! site_hydr%supsub_flag(j) = k +!! site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num +!! else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & +!! (watres_local+small_theta_num)) then +!! site_hydr%supsub_flag(j) = -k +!! site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num +!! else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & dth_layershell_col(j,k) - end if +!! end if enddo + if(debug)then + mean_theta = sum(site_hydr%h2osoi_liqvol_shell(j,:)*site_hydr%v_shell(j,:))/sum(site_hydr%v_shell(j,:)) + if( (mean_theta < watres_local) ) then + write(fates_log(),*) 'Mean soil layer water content, post fates-hydro integration, below residual.' + write(fates_log(),*) 'layer: ',j + write(fates_log(),*) 'theta res: ',watres_local,' [m3/m3]' + write(fates_log(),*) 'mean theta: ',mean_theta + write(fates_log(),*) 'theta: ',site_hydr%h2osoi_liqvol_shell(j,:) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (mean_theta > bc_in(s)%watsat_sisl(j) ) then + write(fates_log(),*) 'Mean soil layer water content, post fates-hydro integration, above saturation.' + write(fates_log(),*) 'layer: ',j + write(fates_log(),*) 'theta sat: ', bc_in(s)%watsat_sisl(j),' [m3/m3]' + write(fates_log(),*) 'mean theta: ',mean_theta + write(fates_log(),*) 'theta: ',site_hydr%h2osoi_liqvol_shell(j,:) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + ! Update the matric potential in the inner-most shell ! (used for setting tissue potentials of new recruits) call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & @@ -2621,7 +2634,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) dtime*bc_out(s)%qflx_soil2root_sisl(j) enddo !site_hydr%nlevsoi_hyd - + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV @@ -2935,6 +2948,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + + end do !write(fates_log(),*) 'ksu:',ccohort_hydr%kmax_stem_upper(:) @@ -2957,6 +2972,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and ! the list need not be across the whole path from stomata to the last rhizosphere shell, but ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. + ! + ! Note on conventions: + ! "Up" upper, refers to the compartment that is closer to the atmosphere + ! "lo" lower, refers to the compartment that is further from the atmosphere + ! Weird distinction: since flow from one node to another, will include half of + ! a compartment on a upper node, and half a compartment of a lower node. The upp + ! compartment will be contributing its lower compartment, and the lower node + ! will be presenting it upper compartment. Yes, confusing, but non-the-less + ! accurate. ! ------------------------------------------------------------------------------- ! Arguments (IN) @@ -3022,6 +3046,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] + real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) ! out of the total absorbing roots from the whole community of plants, @@ -3046,7 +3071,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! ------------------------------------------------------------------------------- - ! This is the fraction of total absorbing root length that a prototype + ! This is the fraction of total absorbing root length that a single ! plant for this cohort takes up. Note: ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] ! site_hydr%l_aroot_layer(ilayer) is units [m/site] @@ -3216,7 +3241,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if(inode==n_hypool_ag+2)then if(no_ftc_radialk) then ftc_node(inode) = 1.0_r8 - dftc_dtheta_node(inode) = 1.0_r8 + dftc_dtheta_node(inode) = 0.0_r8 end if end if @@ -3423,6 +3448,19 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t solution_found = .true. end if + ! Also check that flux was in the same direction as the total potential + do j = 1,n_hypool_tot-1 + if((h_node(j+1)-h_node(j))>0._r8) then + q_flow = dt_substep * (k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j) + & + B_term(j)*dth_node(j+1) + if(q_flow<0) then + print*,"Flow doesnt match head?" + stop + end if + end if + end do + ! Accumulate the water balance error for diagnostic purposes wb_err = wb_err + wb_step_err From 44feca2abef331c4d8eb2869e83ba6534caad68c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 26 Sep 2019 10:17:20 -0700 Subject: [PATCH 031/114] Changed node structure slightly, below-ground compartments are more balanced in hydro. --- biogeophys/FatesPlantHydraulicsMod.F90 | 311 ++++++++++-------- .../hydro/HydroUTestDriver.py | 10 + main/FatesConstantsMod.F90 | 11 + main/FatesHydraulicsMemMod.F90 | 9 +- parameter_files/fates_params_default.cdl | 2 +- 5 files changed, 210 insertions(+), 133 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 9d0cc7b736..c399bdb8f1 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -35,8 +35,12 @@ module FatesPlantHydraulicsMod use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : mpa_per_pa use FatesConstantsMod, only : m_per_mm + use FatesConstantsMod, only : mg_per_kg use FatesConstantsMod, only : pa_per_mpa use FatesConstantsMod, only : rsnbl_math_prec + use FatesConstantsMod, only : m3_per_mm3 + use FatesConstantsMod, only : cm3_per_m3 + use FatesConstantsMod, only : kg_per_g use EDParamsMod , only : hydr_kmax_rsurf1 use EDParamsMod , only : hydr_kmax_rsurf2 @@ -658,9 +662,8 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) real(r8) :: a_sapwood_target ! sapwood cross-section area at reference height, at target biomass [m2] real(r8) :: bsw_target ! sapwood carbon, at target [kgC] real(r8) :: v_sapwood ! sapwood volume [m3] - real(r8) :: b_troot_carb ! transporting root biomass in carbon units [kgC/indiv] - real(r8) :: b_troot_biom ! transporting root biomass in dry wt units [kg/indiv] real(r8) :: v_troot ! transporting root volume [m3/indiv] + real(r8) :: v_root ! Total (aroot+troot) root volume [m3/indiv] real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] @@ -739,12 +742,8 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - b_troot_carb = b_woody_bg_carb - b_troot_biom = b_troot_carb * C2B - v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8) - - !! BOC not sure if/how we should multiply this by the sapwood fraction - ccohort_hydr%v_troot = v_troot / n_hypool_troot + v_troot = b_woody_bg_carb * C2B / & + (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) ! Estimate absorbing root total length (all layers) @@ -759,6 +758,15 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & l_aroot_tot + ! Calculate Root Tissue density: + ! print*,'root tissue density: ',C2B*mg_per_kg*m3_per_mm3*fnrt_c / v_aroot_tot + + v_root = v_aroot_tot + v_troot + + ! The transporting root donates some of its volume + ! to the layer-by-layer absorbing root (which is now a hybrid compartment) + + ccohort_hydr%v_troot = 0.5 * v_root ! Partition the total absorbing root lengths and volumes into the active soil layers ! ------------------------------------------------------------------------------ @@ -770,7 +778,11 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), bc_in%zi_sisl(nlevsoi_hyd)) end if ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot +! ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot + + ! This is a hybrid absorbing root and transporting root volume + ccohort_hydr%v_aroot_layer(j) = rootfr*(0.5*v_root) + end do if(debug) then @@ -921,6 +933,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper + ncohort_hydr%kmax_aroot_lower = ocohort_hydr%kmax_aroot_lower ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out @@ -1594,26 +1607,20 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s - - do k = 2,nshell + do k = 2,nshell csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + + + + enddo ! loop over rhizosphere shells end if !has l_aroot_layer changed? enddo ! loop over soil layers -! write(fates_log(),*) '-----site geom------' -! do j=1,csite_hydr%nlevsoi_hyd -! write(fates_log(),*) 'j: ',j -! write(fates_log(),*) 'l_aroot: ',csite_hydr%l_aroot_layer(j) -! write(fates_log(),*) 'kmax_upper_shell(j,:):',csite_hydr%kmax_upper_shell(j,:) -! write(fates_log(),*) 'kmax_lower_shell(j,:):',csite_hydr%kmax_lower_shell(j,:) -! end do - - return end subroutine UpdateSizeDepRhizVolLenCon @@ -2388,6 +2395,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + do k = 1,nshell kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant @@ -2925,8 +2933,9 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! transporting root, with the absorbing root's center node ! (kmax_aroot_upper) - ccohort_hydr%kmax_troot_lower(j) = 2.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_upper(j) = 2.0_r8 * kmax_layer + ccohort_hydr%kmax_troot_lower(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_upper(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_lower(j) = 3.0_r8 * kmax_layer end do @@ -2941,7 +2950,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) do j=1,csite_hydr%nlevsoi_hyd ! Surface area of the absorbing roots for a single plant in this layer [m2] - surfarea_aroot_layer = 2._r8 * pi_const *csite_hydr%rs1(j) * ccohort_hydr%l_aroot_layer(j) + surfarea_aroot_layer = 2._r8 * pi_const * & + EDPftvarcon_inst%hydr_rs2(ccohort%pft) * ccohort_hydr%l_aroot_layer(j) ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer @@ -3046,6 +3056,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] + + logical :: test_exit + real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) @@ -3137,6 +3150,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t iter = 0 do while( .not.solution_found ) + + test_exit = .false. + ! These are diagnostics that must be calculated. ! in this routine (uses differentials and actual fluxes) ! So we need to zero them, as they are incremented @@ -3148,23 +3164,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Gracefully quit if too many iterations have been used if(iter>max_iter)then - write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' - write(fates_log(),*) '' - leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & - cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - root_water = ((cohort_hydr%th_troot*cohort_hydr%v_troot) + & - sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - write(fates_log(),*) 'flux: ', q_top_eff*dt_substep - write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & + th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& + rootfr_scaler,aroot_frac_plant) call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -3202,12 +3204,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t bc_in%sucsat_sisl(ilayer), & ! optional for soil bc_in%bsw_sisl(ilayer)) ! optional for soil - if(psi_node(inode)>0._r8) then - write(fates_log(),*) 'positive psi?' - write(fates_log(),*) inode,ilayer,psi_node(inode),th_node(inode),th_node_init(inode) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - ! Get total potential [Mpa] h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) @@ -3448,20 +3444,38 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t solution_found = .true. end if - ! Also check that flux was in the same direction as the total potential - do j = 1,n_hypool_tot-1 - if((h_node(j+1)-h_node(j))>0._r8) then - q_flow = dt_substep * (k_eff(j)*(h_node(j+1)-h_node(j)) + & - A_term(j)*dth_node(j) + & - B_term(j)*dth_node(j+1) - if(q_flow<0) then - print*,"Flow doesnt match head?" - stop - end if - end if + ! Calculate new psi + do inode = 1,n_hypool_tot + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil end do + ! We currently allow super-saturation, but draw the line + ! when the water content surpases the total volume + if( any(th_node(:)>1.0_r8) ) then + test_exit = .true. + solution_found = .false. + exit + end if + + ! Check if any psi values are > 0 + if(any(psi_node(:) > nearzero)) then + test_exit = .true. + solution_found = .false. + exit + end if + + ! Extra checks + if( any(th_node(:)<0._r8) ) then + test_exit = .true. + solution_found = .false. + exit + end if + ! Accumulate the water balance error for diagnostic purposes wb_err = wb_err + wb_step_err @@ -3500,6 +3514,11 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do end if + if(test_exit)then + print*,"Loop exit broken?" + stop + end if + end do ! do istep = 1,nsteps (substep loop) @@ -3508,80 +3527,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do - - ! Do some checks on weird values. - if(debug)then - do inode = 1,n_hypool_tot - - ! Get matric potential [Mpa] - !if(ilayer==20) write(fates_log(),*) ilayer,inode,cohort%pft,th_node(inode),bc_in%watsat_sisl(ilayer) - - if(porous_media(inode)<5) then - if( (th_node(inode) > EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode))) .or. & - (th_node(inode) < EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode)))) then - !!print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode), & - !! EDPftvarcon_inst%hydr_resid_node(cohort%pft,porous_media(inode)), & - !! EDPftvarcon_inst%hydr_thetas_node(cohort%pft,porous_media(inode)) - end if - else - if( (th_node(inode) > bc_in%watsat_sisl(ilayer) ) .or. & - (th_node(inode) < 0.95*bc_in%eff_porosity_sl(ilayer))) then - !!print*,'ilayer:',ilayer,inode,th_node(inode),th_node_init(inode),bc_in%watsat_sisl(ilayer),bc_in%sucsat_sisl(ilayer),bc_in%bsw_sisl(ilayer) - end if - end if - - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - ! Positive psi values are def weird - if(psi_node(inode) > 0._r8) then - write(fates_log(),*) 'positive psi found, dumping network' - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'soil layer:',ilayer - write(fates_log(),*) 'qtop [kg]:',q_top_eff*dt_step - write(fates_log(),*) 'q patch: ',bc_in%qflx_transp_pa(:) - write(fates_log(),*) 'g_sb_laweight: ',cohort%g_sb_laweight - write(fates_log(),*) 'lai: ',cohort%treelai - write(fates_log(),*) 'rs2:',EDPftvarcon_inst%hydr_rs2(cohort%pft) - roota=EDPftvarcon_inst%roota_par(cohort%pft) - rootb=EDPftvarcon_inst%rootb_par(cohort%pft) - if(ilayer==1) then - rootfr = zeng2001_crootfr(roota,rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer-1), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - end if - write(fates_log(),*) 'rootfrac: ', rootfr - write(fates_log(),*) 'total root length: ',sum(cohort_hydr%l_aroot_layer) - write(fates_log(),*) 'dt_substep: ',dt_substep - write(fates_log(),*) 'i theta_init theta mass' - do itest = 1,n_hypool_tot - ! get initial total potential of node: - psi_diag = psi_from_th(cohort%pft, porous_media(itest), th_node_init(itest), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - h_diag = psi_diag + mpa_per_pa*denh2o*grav_earth*z_node(itest) - write(fates_log(),*) 'node',itest,th_node_init(itest),th_node(itest),psi_node(itest),v_node(itest),h_diag,psi_diag - if(itest cohort%co_hydr + ft = cohort%pft + + allocate(psi_node(size(z_node))) + allocate(h_node(size(z_node))) + + write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' + write(fates_log(),*) '' + + do inode = 1,n_hypool_tot + psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & + th_node(inode), & + bc_in%watsat_sisl(ilayer), & ! optional for soil + bc_in%sucsat_sisl(ilayer), & ! optional for soil + bc_in%bsw_sisl(ilayer)) ! optional for soil + h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + end do + + leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & + cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + troot_water = (cohort_hydr%th_troot*cohort_hydr%v_troot) * denh2o + aroot_water = sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:)) * denh2o + + write(fates_log(),*) 'layer: ',ilayer + write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_step) - (w_tot_beg-w_tot_end) + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'troot_water: ',troot_water + write(fates_log(),*) 'aroot_water: ',aroot_water + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'vol, theta, H, kmax-' + write(fates_log(),*) 'flux: ', q_top_eff*dt_step + write(fates_log(),*) 'l:',v_node(1),th_node(1),psi_node(1),h_node(1) + write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler + write(fates_log(),*) 's:',v_node(2),th_node(2),psi_node(2),h_node(2) + write(fates_log(),*) ' ',cohort_hydr%kmax_stem_lower(1)*rootfr_scaler,cohort_hydr%kmax_troot_upper*rootfr_scaler + write(fates_log(),*) 't:',v_node(3),th_node(3),psi_node(3),h_node(3) + write(fates_log(),*) ' ',cohort_hydr%kmax_troot_lower(ilayer),cohort_hydr%kmax_aroot_upper(ilayer) + write(fates_log(),*) 'a:',v_node(4),th_node(4),psi_node(4),h_node(4) + write(fates_log(),*) ' in:',cohort_hydr%kmax_aroot_radial_in(ilayer),site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + write(fates_log(),*) ' out:',cohort_hydr%kmax_aroot_radial_out(ilayer),site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + write(fates_log(),*) 'r1:',v_node(5),th_node(5),psi_node(5),h_node(5) + write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant + write(fates_log(),*) 'r2:',v_node(6),th_node(6),psi_node(6),h_node(6) + write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant + write(fates_log(),*) 'r3:',v_node(7),th_node(7),psi_node(7),h_node(7) + write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant + write(fates_log(),*) 'r4:',v_node(8),th_node(8),psi_node(8),h_node(8) + write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant + write(fates_log(),*) 'r5:',v_node(9),th_node(9),psi_node(9),h_node(9) + write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) + write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),site_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'kmax_upper_shell: ',site_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant + write(fates_log(),*) 'kmax_lower_shell: ',site_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant + write(fates_log(),*) '' + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + + deallocate(psi_node) + deallocate(h_node) + + + ! Most likely you will want to end-run after this routine, but maybe not... + + return + end subroutine Report1DError + ! ================================================================================= subroutine GetImTaylorKAB(kmax_lo,kmax_up, & diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index bc28ffc1bd..5277fff706 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -431,6 +431,16 @@ def main(argv): for i,psi in enumerate(leaf_psi): leaf_flc[i] = flc_from_psi(ci(pft1), ci(pm_leaf), c8(leaf_theta[i]), c8(psi)) + leaf_thsat = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft1-1] + + cap_func = (1.0-(leaf_thsat-leaf_theta[i])/leaf_thsat)**2.0 + + leaf_flcc[i] = leaf_flc[i]*cap_func + + # This function must tend towards positive + cap_func = del_theta / ( leaf_thsat-leaf_theta) + + for i,psi in enumerate(stem_psi): stem_flc[i] = flc_from_psi(ci(pft1), ci(pm_stem), c8(stem_theta[i]), c8(psi)) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 6b9134083a..a13ef7ef24 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -70,6 +70,9 @@ module FatesConstantsMod ! Conversion factor: grams per kilograms real(fates_r8), parameter, public :: g_per_kg = 1000.0_fates_r8 + ! Conversion factor: kilograms per gram + real(fates_r8), parameter, public :: kg_per_g = 0.001_fates_r8 + ! Conversion factor: miligrams per grams real(fates_r8), parameter, public :: mg_per_g = 1000.0_fates_r8 @@ -100,6 +103,14 @@ module FatesConstantsMod ! Conversion factor: cm2 per m2 real(fates_r8), parameter, public :: cm2_per_m2 = 10000.0_fates_r8 + ! Conversion factor: m3 per mm3 + real(fates_r8), parameter, public :: m3_per_mm3 = 1.0E-9_fates_r8 + + ! Conversion factor: cubic meters per cubic cm + real(fates_r8), parameter, public :: m3_per_cm3 = 1.0E-6_fates_r8 + + real(fates_r8), parameter, public :: cm3_per_m3 = 1.0E6_fates_r8 + ! Conversion factor :: ha per m2 real(fates_r8), parameter, public :: ha_per_m2 = 1.0e-4_fates_r8 diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index eb3d207bf1..9949b4c02e 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -60,7 +60,7 @@ module FatesHydraulicsMemMod integer, parameter, public :: nlevcan_hyd = 2 ! Mean fine root radius expected in the bulk soil - real(r8), parameter, public :: fine_root_radius_const = 0.001_r8 + real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 ! Constant parameters (for time being, C2B is constant, ! slated for addition to parameter file (RGK 08-2017)) @@ -194,6 +194,11 @@ module FatesHydraulicsMemMod real(r8),allocatable :: kmax_aroot_upper(:) ! Max conductance in the absorbing root ! compartment through xylem tissues going ! into the transporting root + real(r8),allocatable :: kmax_aroot_lower(:) ! Since this pools may actually be a + ! hybrid that contains transporting + ! root volume, then we need to factor + ! in xylem resistance from the absorbing + ! root edge to the node center ! Max conductance in the absorbing ! root compartment, radially through the @@ -309,6 +314,7 @@ subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) allocate(this%kmax_troot_lower(1:nlevsoil_hydr)) allocate(this%kmax_aroot_upper(1:nlevsoil_hydr)) + allocate(this%kmax_aroot_lower(1:nlevsoil_hydr)) allocate(this%kmax_aroot_radial_in(1:nlevsoil_hydr)) allocate(this%kmax_aroot_radial_out(1:nlevsoil_hydr)) allocate(this%v_aroot_layer_init(1:nlevsoil_hydr)) @@ -330,6 +336,7 @@ subroutine DeallocateHydrCohortArrays(this) deallocate(this%kmax_troot_lower) deallocate(this%kmax_aroot_upper) + deallocate(this%kmax_aroot_lower) deallocate(this%kmax_aroot_radial_in) deallocate(this%kmax_aroot_radial_out) deallocate(this%v_aroot_layer_init) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 49b7662508..708220f425 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -157,7 +157,7 @@ variables: fates_hydr_fcap_node:units = "unitless" ; fates_hydr_fcap_node:long_name = "fraction of (1-resid_node) that is capillary in source" ; double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; - fates_hydr_kmax_node:units = "kgMPa/m/s" ; + fates_hydr_kmax_node:units = "kg/MPa/m/s" ; fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; double fates_hydr_p50_gs(fates_pft) ; fates_hydr_p50_gs:units = "MPa" ; From f45ff5706c9a8cfd32aef808098020cbad896fd3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 27 Sep 2019 10:33:54 -0700 Subject: [PATCH 032/114] Fixed sign error in eleveations in hydro refactor. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 98 +++++--- biogeophys/FatesPlantHydraulicsMod.F90 | 214 ++++++++++++------ .../hydro/HydroUTestDriver.py | 15 +- 3 files changed, 206 insertions(+), 121 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index c8879ce624..bbe8fec938 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -55,7 +55,17 @@ module FatesHydroUnitFunctionsMod ! this is used to calculate a ! lower theta bound ! [MPa/ m3/m3] + + ! Parameter to enable some positive pressure in soils, just to avoid super-saturation + ! which will cause problems for a host model. These parameters are roughly + ! tuned to get 0.5 MPa positive pressure at exactly saturation, starting + ! a parabolic curve from the offset. + real(r8), parameter :: ss_wcoff = 0.05 ! WC offset from saturation, from which + ! we start to adding some positive pressure + ! to avoid super-saturation + real(r8), parameter :: ss_a = 15.0_r8 ! slope parameter for positive pressure function + real(r8), parameter :: ss_b = 2.0_r8 ! slope parameter for positive pressure function ! P-V curve: total RWC @ which elastic drainage begins [-] real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) @@ -207,16 +217,18 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) err = abs(r(k) - (a(k)*u(k-1)+b(k)*u(k))) end if - rel_err = abs(err/u(k)) - - if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then - write(fates_log(),*) 'Tri-diagonal solve produced solution with' - write(fates_log(),*) 'non-negligable error.' - write(fates_log(),*) 'Compartment: ',k - write(fates_log(),*) 'Error in forward solution: ',err - write(fates_log(),*) 'Estimated delta theta: ',u(k) - write(fates_log(),*) 'Rel Error: ',rel_err - call endrun(msg=errMsg(sourcefile, __LINE__)) + if(abs(u(k))>nearzero)then + rel_err = abs(err/u(k)) + + if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if end do @@ -295,12 +307,15 @@ function flc_from_psi(ft, pm, th_in, psi_in, suc_sat, bsw) result(flc_node) if(pm <= 4) then if(allow_unconstrained_theta) then - if(th_inpft_p%hydr_thetas_node(ft,pm)) then + psi_resid = psi_from_th(ft,pm,pft_p%hydr_thetas_node(ft,pm)) + flc_node = 1._r8/(1._r8 + (psi_resid/p50(ft,pm))**avuln(ft,pm)) ! should be 1 + elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then + dflcdpsi_node = 0._r8 + elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then - ! Hard cap water content at saturation - call tq2(ft, pm, pft_p%hydr_thetas_node(ft,pm)*cap_corr(pm), psi_node) - elseif(th_in<(pft_p%hydr_resid_node(ft,pm)+nearzero)) then +! if(th_in>pft_p%hydr_thetas_node(ft,pm)) then +! ! Hard cap water content at saturation +! call tq2(ft, pm, pft_p%hydr_thetas_node(ft,pm)*cap_corr(pm), psi_node) +! else + if(th_in<(pft_p%hydr_resid_node(ft,pm)+nearzero)) then ! Perform extrapolation from residual WC call tq2(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), psi_resid) call dtq2dth(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), dpsidth_resid) @@ -616,8 +637,9 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & bsw) - if(th_in>th_sat) then - psi_node = suc_sat_mpa + ! If we are nearing saturation, we allow some positive pressure to avoid super-saturation + if(th_in>(th_sat-ss_wcoff)) then + psi_node = suc_sat_mpa + (ss_a*(th_in-(th_sat-ss_wcoff)))**ss_b elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then - ! The derivative at the hard-cap is 0 - dpsidth = 0._r8 - elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then +! ! The derivative at the hard-cap is 0 +! dpsidth = 0._r8 +! else + if(th_inth_sat) then - dpsidth = 0._r8 + ! If we are nearing saturation, we allow some positive pressure to avoid super-saturation + if(th_in>(th_sat-ss_wcoff)) then + call swcCampbell_dpsidth_from_th(th_in, & + th_sat, & + -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & + bsw, & + dpsidth) + dpsidth = dpsidth + ss_b*(ss_a*(th_in-(th_sat-ss_wcoff)))**(ss_b-1._r8)*ss_a elseif(th_in<=th_cap) then dpsidth = max_dpsidth else diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index c399bdb8f1..bd9d60c500 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -370,9 +370,14 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !the assumption is made here that initial conditions for soil water will !be in (or at least close to) hydrostatic equilibrium as well, so that !it doesn't matter which absorbing root layer the transporting root water - !potential is referenced to. + !potential is referenced to. - dz = ccohort_hydr%z_node_troot - bc_in%z_sisl(1) + !(positive means troot is higher than aroot) + ! h_troot = h_aroot + ! psi_troot + z_troot = psi_aroot + z_aroot + ! psi_troot = psi_aroot - (z_troot - z_aroot) + + dz = ccohort_hydr%z_node_troot - (-bc_in%z_sisl(1)) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - mpa_per_pa*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 @@ -782,7 +787,6 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! This is a hybrid absorbing root and transporting root volume ccohort_hydr%v_aroot_layer(j) = rootfr*(0.5*v_root) - end do if(debug) then @@ -1596,28 +1600,28 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! Set the max conductance on the inner shell first. If the node radius ! on the shell is smaller than the root radius, just set the max conductance ! to something extremely high. - - if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then - csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound - else - csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s - end if - - csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s - + + if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then + csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound + else + csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + end if + + csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s + do k = 2,nshell - csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - - csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s + + csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + enddo ! loop over rhizosphere shells + + - - - enddo ! loop over rhizosphere shells end if !has l_aroot_layer changed? enddo ! loop over soil layers @@ -2520,10 +2524,18 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! after all cohort-layers are complete. This allows each cohort ! to experience the same water conditions (for good or bad). + if(site_hydr%l_aroot_layer(j) & -!! (bc_in(s)%watsat_sisl(j)-small_theta_num)) then +! if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & +! (bc_in(s)%watsat_sisl(j)-small_theta_num)) then !! site_hydr%supsub_flag(j) = k -!! site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num +! site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num !! else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & !! (watres_local+small_theta_num)) then !! site_hydr%supsub_flag(j) = -k !! site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num -!! else +! else site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & dth_layershell_col(j,k) -!! end if +! end if enddo if(debug)then @@ -3041,6 +3053,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] + real(r8) :: error_arr(n_hypool_tot) ! array that saves problematic diagnostics for reporting real(r8) :: dftc_dtheta_node(n_hypool_tot) ! deriv FTC w.r.t. theta real(r8) :: dpsi_dtheta_node(n_hypool_tot) ! deriv psi w.r.t. theta real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] @@ -3056,7 +3069,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] - + integer :: error_code ! flag that specifies which check tripped a failed solution + logical :: test_exit real(r8) :: q_flow ! flow diagnostic [kg] @@ -3066,7 +3080,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps ! by this much - integer, parameter :: max_iter = 10 ! Maximum number of iterations with which we reduce timestep + integer, parameter :: max_iter = 20 ! Maximum number of iterations with which we reduce timestep real(r8), parameter :: max_wb_step_err = 1.e-7_r8 real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [mm h2o] @@ -3129,12 +3143,12 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t v_node(inode) = cohort_hydr%v_troot th_node_init(inode) = cohort_hydr%th_troot elseif (inode==n_hypool_ag+2) then - z_node(inode) = bc_in%z_sisl(ilayer) + z_node(inode) = -bc_in%z_sisl(ilayer) v_node(inode) = cohort_hydr%v_aroot_layer(ilayer) th_node_init(inode) = cohort_hydr%th_aroot(ilayer) else ishell = inode-(n_hypool_ag+2) - z_node(inode) = bc_in%z_sisl(ilayer) + z_node(inode) = -bc_in%z_sisl(ilayer) ! The volume of the Rhizosphere for a single plant v_node(inode) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) @@ -3166,7 +3180,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if(iter>max_iter)then call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& - rootfr_scaler,aroot_frac_plant) + rootfr_scaler,aroot_frac_plant,error_code,error_arr) call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -3347,9 +3361,11 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Special case. Maximum conductance depends on the ! potential gradient. if(h_node(i_up) < h_node(i_lo) ) then - kmax_up = cohort_hydr%kmax_aroot_radial_in(ilayer) + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) else - kmax_up = cohort_hydr%kmax_aroot_radial_out(ilayer) + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) end if kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant @@ -3436,12 +3452,15 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t if(abs(wb_step_err)>max_wb_step_err)then solution_found = .false. + error_code = 1 + error_arr(:) = 0._r8 exit else ! Note: this is somewhat of a default true. And the sub-steps ! will keep going unless its changed and broken out of ! the loop. solution_found = .true. + error_code = 0 end if ! Calculate new psi @@ -3454,27 +3473,41 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t end do ! We currently allow super-saturation, but draw the line - ! when the water content surpases the total volume + ! at 100% of volume... if( any(th_node(:)>1.0_r8) ) then test_exit = .true. solution_found = .false. + error_code = 2 + error_arr(:) = th_node(:) exit end if - - ! Check if any psi values are > 0 - if(any(psi_node(:) > nearzero)) then - test_exit = .true. - solution_found = .false. - exit + ! We dont allow any super-saturaiton in soil nodes + if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then + test_exit = .true. + solution_found = .false. + error_code = 4 + error_arr(:) = th_node(:) + exit end if - + ! Extra checks if( any(th_node(:)<0._r8) ) then test_exit = .true. solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) exit end if + + ! Check if any psi values are > 0 + !if(any(psi_node(:) > nearzero)) then + ! test_exit = .true. + ! solution_found = .false. + ! error_code = 4 + ! error_arr(:) = psi_node(:) + ! exit + !end if ! Accumulate the water balance error for diagnostic purposes wb_err = wb_err + wb_step_err @@ -3585,26 +3618,30 @@ end subroutine ImTaylorSolve1D ! ===================================================================================== - subroutine Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node,th_node,q_top_eff,dt_step,w_tot_beg,w_tot_end,rootfr_scaler,aroot_frac_plant) + subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & + th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & + rootfr_scaler, aroot_frac_plant, err_code, err_arr) ! This routine reports what the initial condition to the 1D solve looks ! like, and then quits. - ! Arguments (IN) - type(ed_cohort_type),intent(in),target :: cohort - type(ed_site_hydr_type), intent(in), target :: site_hydr - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions - integer, intent(in) :: ilayer ! soil layer index of interest - real(r8), intent(in) :: z_node(:) ! elevation of nodes - real(r8), intent(in) :: v_node(:) ! volume of nodes - real(r8), intent(in) :: th_node(:) ! water content of node - real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] - real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] - real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] - real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? - real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots - ! in the soil continuum is from current plant? + ! Arguments (IN) + type(ed_cohort_type),intent(in),target :: cohort + type(ed_site_hydr_type),intent(in), target :: site_hydr + type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions + integer, intent(in) :: ilayer ! soil layer index of interest + real(r8), intent(in) :: z_node(:) ! elevation of nodes + real(r8), intent(in) :: v_node(:) ! volume of nodes + real(r8), intent(in) :: th_node(:) ! water content of node + real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution + real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] + real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] + real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] + real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? + real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots + ! in the soil continuum is from current plant? + integer, intent(in) :: err_code ! error code + real(r8), intent(in) :: err_arr(:) ! error diagnostic type(ed_cohort_hydr_type),pointer :: cohort_hydr integer :: inode @@ -3624,6 +3661,8 @@ subroutine Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node,th_node,q_t write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' write(fates_log(),*) '' + write(fates_log(),*) 'error code: ',err_code + write(fates_log(),*) 'error diag: ',err_arr(:) do inode = 1,n_hypool_tot psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & @@ -3650,26 +3689,32 @@ subroutine Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node,th_node,q_t write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) write(fates_log(),*) 'dbh: ',cohort%dbh write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'z nodes: ',z_node(:) + write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) write(fates_log(),*) 'vol, theta, H, kmax-' write(fates_log(),*) 'flux: ', q_top_eff*dt_step - write(fates_log(),*) 'l:',v_node(1),th_node(1),psi_node(1),h_node(1) + write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1) write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler - write(fates_log(),*) 's:',v_node(2),th_node(2),psi_node(2),h_node(2) - write(fates_log(),*) ' ',cohort_hydr%kmax_stem_lower(1)*rootfr_scaler,cohort_hydr%kmax_troot_upper*rootfr_scaler - write(fates_log(),*) 't:',v_node(3),th_node(3),psi_node(3),h_node(3) - write(fates_log(),*) ' ',cohort_hydr%kmax_troot_lower(ilayer),cohort_hydr%kmax_aroot_upper(ilayer) - write(fates_log(),*) 'a:',v_node(4),th_node(4),psi_node(4),h_node(4) - write(fates_log(),*) ' in:',cohort_hydr%kmax_aroot_radial_in(ilayer),site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - write(fates_log(),*) ' out:',cohort_hydr%kmax_aroot_radial_out(ilayer),site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - write(fates_log(),*) 'r1:',v_node(5),th_node(5),psi_node(5),h_node(5) - write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant - write(fates_log(),*) 'r2:',v_node(6),th_node(6),psi_node(6),h_node(6) - write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant - write(fates_log(),*) 'r3:',v_node(7),th_node(7),psi_node(7),h_node(7) - write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant - write(fates_log(),*) 'r4:',v_node(8),th_node(8),psi_node(8),h_node(8) - write(fates_log(),*) ' ',site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant,site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant - write(fates_log(),*) 'r5:',v_node(9),th_node(9),psi_node(9),h_node(9) + write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2) + write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) + write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) + write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) 'a:',v_node(4),th_node(4),h_node(4) + write(fates_log(),*) ' in:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer) + & + 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) ' out:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer) + & + 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) 'r1:',v_node(5),th_node(5),h_node(5) + write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant)) + write(fates_log(),*) 'r2:',v_node(6),th_node(6),h_node(6) + write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant)) + write(fates_log(),*) 'r3:',v_node(7),th_node(7),h_node(7) + write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant)) + write(fates_log(),*) 'r4:',v_node(8),th_node(8),h_node(8) + write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant)) + write(fates_log(),*) 'r5:',v_node(9),th_node(9),h_node(9) write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),site_hydr%l_aroot_layer(ilayer) @@ -3677,7 +3722,26 @@ subroutine Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node,th_node,q_t write(fates_log(),*) 'kmax_lower_shell: ',site_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant write(fates_log(),*) '' write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'area and area to volume ratios' + write(fates_log(),*) '' + write(fates_log(),*) 'a:',v_node(4) + write(fates_log(),*) ' ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'r1:',v_node(5) + write(fates_log(),*) ' ',2._r8 * pi_const * site_hydr%r_out_shell(ilayer,1) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'r2:',v_node(6) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r3:',v_node(7) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r4:',v_node(8) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r5:',v_node(9) + + write(fates_log(),*) 'inner shell kmaxs: ',site_hydr%kmax_lower_shell(:,1)*aroot_frac_plant + + + + deallocate(psi_node) deallocate(h_node) diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 5277fff706..cf37b454f5 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -26,6 +26,9 @@ from operator import add + + + CDLParse = imp.load_source('CDLParse','../shared/py_src/CDLParse.py') F90ParamParse = imp.load_source('F90ParamParse','../shared/py_src/F90ParamParse.py') PyF90Utils = imp.load_source('PyF90Utils','../shared/py_src/PyF90Utils.py') @@ -344,7 +347,7 @@ def main(argv): ax1.grid(True) ax1.set_ylabel('Psi') ax1.set_xlim((0,1)) - ax1.set_ylim((-20,0)) + ax1.set_ylim((-20,10)) ax1.set_xlabel('Theta') ax1.set_title('PFT: {}'.format(pft1)) ax1.legend(loc='lower right') @@ -431,16 +434,6 @@ def main(argv): for i,psi in enumerate(leaf_psi): leaf_flc[i] = flc_from_psi(ci(pft1), ci(pm_leaf), c8(leaf_theta[i]), c8(psi)) - leaf_thsat = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft1-1] - - cap_func = (1.0-(leaf_thsat-leaf_theta[i])/leaf_thsat)**2.0 - - leaf_flcc[i] = leaf_flc[i]*cap_func - - # This function must tend towards positive - cap_func = del_theta / ( leaf_thsat-leaf_theta) - - for i,psi in enumerate(stem_psi): stem_flc[i] = flc_from_psi(ci(pft1), ci(pm_stem), c8(stem_theta[i]), c8(psi)) From 19dccf40d6ed85de4039afc6616f08ebfba1ca83 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 30 Sep 2019 09:47:32 -0700 Subject: [PATCH 033/114] Started new water transfer functions module. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 218 ++++++++++++++------- biogeophys/FatesHydroWTFMod.F90 | 220 ++++++++++++++++++++++ 2 files changed, 372 insertions(+), 66 deletions(-) create mode 100644 biogeophys/FatesHydroWTFMod.F90 diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index bbe8fec938..9b64748d6c 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -37,9 +37,19 @@ module FatesHydroUnitFunctionsMod integer, parameter :: rkvol = 2 integer, parameter :: voltype = rkvol - integer, public, parameter :: van_genuchten = 1 - integer, public, parameter :: campbell = 2 - integer, public, parameter :: iswc = campbell + ! We have an array of options for different PV curves. + ! Note that we can also use a hybrid of PV curves + ! for soil, and those targetted for plants, which + ! factor in elastic ranges, capilary ranges and cavitation + ! ranges in plants (eccp). *Note, we have found that + ! mixing different PV methods, while scientifically interesting + ! *may* lead to strange and unstable behavior. + + integer, public, parameter :: van_genuchten = 1 + integer, public, parameter :: campbell = 2 + integer, public, parameter :: van_genuchten_eccp = 3 + integer, public, parameter :: campbell_eccp = 4 + integer, public, parameter :: iswc = van_genuchten logical, public, parameter :: allow_unconstrained_theta = .true. @@ -102,8 +112,29 @@ module FatesHydroUnitFunctionsMod public :: swcCampbell_psi_from_th + ! This is the base type for all pedotransfer functions (PTFs) + ! Currently, we are mostly using water release curves, we may + ! add conductivity calculations. + ! Note, that the standard convention for allocating parameters + ! is to assign soil layers as negative indices, and + ! special porous media (i.e. aroot, troot, stem and leaves) + + + + + + contains + + + + + + + + + ! ===================================================================================== subroutine InitAllocatePlantMedia(n_plant_media) @@ -439,14 +470,37 @@ function th_from_psi(ft, pm, psi_node, th_sat, suc_sat, bsw) result(th_node) real(r8) :: satfrac ! soil saturation fraction [0-1] real(r8) :: psi_check + !integer, public, parameter :: van_genuchten = 1 + !integer, public, parameter :: campbell = 2 + !integer, public, parameter :: van_genuchten_eccp = 3 + !integer, public, parameter :: campbell_eccp = 4 + associate(& thetas => pft_p%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual water fraction ) + ! This is a plant compartment if(pm <= 4) then + select case(iswc) + + case(van_genuchten) + + + case(campbell) + + + case(van_genuchten_eccp,campbell_eccp) + + + case default + write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + lower = thetas(ft,pm)*(resid(ft,pm) + 0.0001_r8)/cap_corr(pm) upper = thetas(ft,pm) xtol = 1.e-16_r8 @@ -559,7 +613,7 @@ end subroutine bisect_pv !===============================================================================! - function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) + function psi_from_th(ft, pm, th_in, th_sat, th_res, suc_sat, bsw) result(psi_node) ! ! !DESCRIPTION: evaluates the plant PV curve (returns water potential, psi) @@ -588,28 +642,34 @@ function psi_from_th(ft, pm, th_in, th_sat, suc_sat, bsw) result(psi_node) real(r8) :: dthdpsi_cap ! derivative at th_cap (for extrapolation) real(r8) :: suc_sat_mpa ! Suction at saturation in [MPa] - + th_in>pft_p%hydr_thetas_node(ft,pm)) then +! ! The derivative at the hard-cap is 0 +! dpsidth = 0._r8 +! else + if(th_inpft_p%hydr_thetas_node(ft,pm)) then -! ! Hard cap water content at saturation -! call tq2(ft, pm, pft_p%hydr_thetas_node(ft,pm)*cap_corr(pm), psi_node) -! else - if(th_in<(pft_p%hydr_resid_node(ft,pm)+nearzero)) then - ! Perform extrapolation from residual WC - call tq2(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), psi_resid) - call dtq2dth(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), dpsidth_resid) - psi_node = psi_resid + (th_in-pft_p%hydr_resid_node(ft,pm)) * dpsidth_resid - else - call tq2(ft, pm, th_in*cap_corr(pm), psi_node) - end if - else - call tq2(ft, pm, th_in*cap_corr(pm), psi_node) - end if - + + select case(iswc) + case(van_genuchten) + + psi_node = PsiFromThVG(th_in,pft_p%hydr_thetas_node(ft,pm),pft_p%hydr_resid_node(ft,pm), + + case(campbell) + + + case(van_genuchten_eccp,campbell_eccp) + + psi_node = PsiFromThECCP(ft,pm,th_in) + + case default + write(fates_log(),*) 'invalid soil water characteristic function specified, iswc = '//char(iswc) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select else if(pm == 5) then ! soil @@ -774,7 +834,29 @@ function swcCampbell_th_from_dpsidth(th_sat,psi_sat,bsw) result(th) return end function swcCampbell_th_from_dpsidth + ! ==================================================================================== + function PsiFromThECCP(ft,pm,th_in) result (psi_node) + + integer :: ft + integer :: pm + real(r8) :: th_in + + real(r8) :: psi_node + + if(th_in<(pft_p%hydr_resid_node(ft,pm)+nearzero)) then + ! Perform extrapolation from residual WC + call tq2(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), psi_resid) + call dtq2dth(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), dpsidth_resid) + psi_node = psi_resid + (th_in-pft_p%hydr_resid_node(ft,pm)) * dpsidth_resid + else + call tq2(ft, pm, th_in*cap_corr(pm), psi_node) + end if + + + return + end subroutine PsiFromThECCP + !===============================================================================! subroutine tq2(ft, pm, x, y) @@ -1503,7 +1585,7 @@ end subroutine swcCampbell_psi_from_th !===============================================================================! - subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) + subroutine swcVG_psi_from_th(th,alpha,n,th_sat,th_res,psi) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -1512,19 +1594,28 @@ subroutine swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ + real(r8), intent(in) :: th ! vol wat content [m3/m3] + real(r8), intent(in) :: alpha ! inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n ! pore-size distribution index [-] + real(r8), intent(in) :: th_sat ! vwc at saturation [m3/m3] + real(r8), intent(in) :: th_res ! vwc at residual [m3/m3] + real(r8), intent(out) :: psi !soil matric potential [MPa] + + ! local variables + real(r8) :: satfrac !saturation fraction [0-1] + + !------------------------------------------------------------------------------------ + ! saturation fraction is the origial equation in vg 1980, we just + ! need to invert it: + ! satfrac = (1._r8 + (alpha*psi)**n)**(1._r8/n-1) + ! ----------------------------------------------------------------------------------- + + satfrac = (th-th_res)/(th_sat-th_res) - psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) + psi = (1._r8/alpha)*(satfrac**(1._r8/(1._r8/n-1._r8)) - 1._r8 )**(1._r8/n) - end subroutine swcVG_psi_from_satfrac + + end subroutine swcVG_psi_from_th !===============================================================================! @@ -1549,28 +1640,6 @@ subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) end subroutine swcCampbell_psi_from_satfrac - !===============================================================================! - - subroutine swcVG_th_from_satfrac(satfrac, watsat, watres, th) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water content given saturation fraction, porosity and residual water content - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - th = watres + satfrac*(watsat - watres) - - end subroutine swcVG_th_from_satfrac !===============================================================================! @@ -1595,7 +1664,7 @@ subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) end subroutine swcCampbell_th_from_satfrac !======================================================================- - subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) + subroutine swcVG_th_from_psi(psi, alpha, n, th_sat, th_res, satfrac) ! ! DESCRIPTION ! van Genuchten (1980) soil water characteristic (retention) curve @@ -1604,19 +1673,36 @@ subroutine swcVG_satfrac_from_psi(psi, alpha, n, m, l, satfrac) !USES ! ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] + real(r8), intent(in) :: psi ! soil matric potential [MPa] + real(r8), intent(in) :: alpha ! inverse of air-entry pressure [MPa-1] + real(r8), intent(in) :: n ! pore-size distribution index [-] + real(r8), intent(in) :: m ! = 1 - 1/n_VG [-] + real(r8), intent(in) :: l ! pore tortuosity parameter [-] + real(r8), intent(in) :: th_sat ! saturation vwc [m3/m3] + real(r8), intent(in) :: th_res ! residual vwc [m3/m3] + real(r8), intent(out) :: th ! vol water content [m3/m3] + + real(r8) :: satfrac !soil saturation fraction [0-1] ! ! !LOCAL VARIABLES: !------------------------------------------------------------------------------ - satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m + !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m + + ! Saturation fraction + satfrac = (1._r8 + (alpha*psi)**n)**(-1+(1._r8/n)) + + ! convert to volumetric water content + th = satfrac*(th_sat-th_res) + th_res + + + end subroutine swcVG_th_from_psi + + + + + - end subroutine swcVG_satfrac_from_psi !======================================================================- subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 new file mode 100644 index 0000000000..c9dd9cce92 --- /dev/null +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -0,0 +1,220 @@ +module FatesHydroWTFMod + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : pa_per_mpa + use FatesConstantsMod, only : mpa_per_pa + use FatesConstantsMod, only : mm_per_m + use FatesConstantsMod, only : m_per_mm + use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water + use FatesConstantsMod, only : grav_earth + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : pi_const + + implicit none + private + + ! ------------------------------------------------------------------------------------- + ! This module contains all unit (F)unctions associated with (W)ater (T)ransfer. + ! e.g. WTFs + ! These are also called "pedotransfer" functions, however, since these + ! may be applied to xylems, stems, etc, they are not limited to soils (pedo). + ! ------------------------------------------------------------------------------------- + + ! Generic class that can be extended to describe + ! specific Pedo-transfer Functions + + type, public :: wtf_type + + ! These base pointers should never be actually called + procedure :: th_from_psi => th_from_psi_base + procedure :: psi_from_th => psi_from_th_base + procedure :: dpsidth_from_th => dpsidth_from_th_base + procedure :: flc_from_th => flc_from_th_base + procedure :: dflc_from_th => dflcdth_from_th_base + procedure :: set_param => set_param_base + + end type wtf_type + + ! The Van Genuchten Pedo-transfer functions + type, public, extends(wtf_type) :: wtf_type_vg + + real(r8), allocatable :: alpha ! Inverse air entry parameter + real(r8), allocatable :: psd ! Inverse width of pore size distribution parameter + real(r8), allocatable :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8), allocatable :: th_res ! Residual volumetric water content [m3/m3] + + contains + + procedure :: th_from_psi => th_from_psi_vg + procedure :: psi_from_th => psi_from_th_vg + procedure :: dpsidth_from_th => dpsidth_from_th_vg + procedure :: flc_from_th => flc_from_th_vg + procedure :: dflc_from_th => dflcdth_from_th_vg + procedure :: set_param => set_param_vg + + end type wtf_type_vg + + + ! This object holds all of the functions and + ! parameters for the different porous media types + type(pft_type), public, pointer :: wtfs(:) + + +contains + + ! ===================================================================================== + + subroutine set_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in) + + class(wtf_type_vg) :: this + real(r8), intent(in) :: alpha_in + real(r8), intent(in) :: psd_in + real(r8), intent(in) :: th_sat_in + real(r8), intent(in) :: th_res_in + + this%alpha = alpha_in + this%psd = psd_in + this%th_sat = th_sat_in + this%th_res = th_res_in + + return + end subroutine set_param_vg + + ! ===================================================================================== + + function th_from_psi_vg(psi) result(th) + + ! Van Genuchten (1980) calculation of volumetric water content (theta) + ! from matric potential. + + class(wtf_type_vg) :: this + real(r8), intent(in) :: psi + real(r8) :: satfrac + real(r8) :: th + + !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m + ! Saturation fraction + + satfrac = (1._r8 + (this%alpha*psi)**this%psd)**(-1+(1._r8/this%psd)) + + ! convert to volumetric water content + th = satfrac*(this%th_sat-this%th_res) + this%th_res + + end function th_from_psi_vg + + ! ===================================================================================== + + function psi_from_th_vg(th) result(psi) + + ! Van Genuchten (1980) calculation of matric potential from + ! volumetric water content (theta). + + class(wtf_type_vg) :: this + real(r8),intent(in) :: th + real(r8) :: psi + real(r8) :: satfrac + + !------------------------------------------------------------------------------------ + ! saturation fraction is the origial equation in vg 1980, we just + ! need to invert it: + ! satfrac = (1._r8 + (alpha*psi)**n)**(1._r8/n-1) + ! ----------------------------------------------------------------------------------- + + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + + psi = (1._r8/this%alpha)*(satfrac**(1._r8/(1._r8/this%psd-1._r8)) - 1._r8 )**(1._r8/this%psd) + + end function psi_from_th_vg + + ! ===================================================================================== + + function dpsidth_from_th_vg(th) result(dpsidth) + + class(wtf_type_vg) :: this + real(r8),intent(in) :: th + real(r8) :: a1 ! parameter intermediary + real(r8) :: m1 ! parameter intermediary + real(r8) :: m2 ! parameter intermediary + real(r8) :: satfrac ! saturation fraction + + a1 = 1._r8/this%alpha + m1 = 1._r8/this%psd + m2 = 1._r8/(m1-1._r8) + + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + + ! psi = a1*(satfrac**m2 - 1._r8 )**m1 + ! f(x) = satfrac**m2 -1 + ! g(x) = a1*f(x)**m1 + ! dpsidth = g'(f(x)) f'(x) + + dpsidth = (m2/(this%th_sat - this%th_res))*m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) + + end function dpsidth_from_th_vg + + + ! ===================================================================================== + + + function flc_from_th_vg(th) result(flc) + + num = (1._r8 - (this%alpha*psi)**(this%psd-1._r8) * & + (1._r8 + (this%alpha*psi)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 + den = (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*(1._r8-1._r8/this%psd)) + + flc = num/den + + + end function flc_from_th_vg + + ! ==================================================================================== + + function dflcdpsi_from_psi_vg(th) result(dflcdpsi) + + + ! The derivative of the fraction of total conductivity + ! Note, this function is fairly complex. To get the derivative + ! we brake it into terms, and also into numerator and denominator + ! and then differentiate those by parts + class(wtf_type_vg) :: this + real(r8),intent(in) :: psi + real(r8) :: t1 ! term 1 in numerator + real(r8) :: t2 ! term 2 in numerator + real(r8) :: dt1 ! derivative of term 1 + real(r8) :: dt2 ! derivative of term 2 + real(r8) :: num ! numerator + real(r8) :: dnum ! derivative of numerator + real(r8) :: den ! denominator + real(r8) :: dden ! derivative of denominator + real(r8) :: dflcdpsi ! change in frac total cond wrt psi + + + t1 = (this%alpha*psi)**(this%psd-1._r8) + dt1 = this%alpha**(this%psd-1._r8)*(this%psd-1._r8)*psi**(this%psd-2._r8) + + t2 = (1._r8 + (this%alpha*psi)**this%psd)**-(1._r8-1._r8/this%psd) + dt2 = -(1._r8-1._r8/this%psd) * (1._r8 + (this%alpha*psi)**this%psd)**(1._r8/this%psd) * this%psd*(this%alpha**psd)*psi**(this%psd-1._r8) + + num = (1._r8 - t1*t2)**2._r8 + dnum = 2._r8 * (1._r8 - t1*t2) * ( t1*dt2 + t2*dt1 ) + + den = (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*( 1._r8-1._r8/this%psd)) + dden = (this%lt*( 1._r8-1._r8/this%psd)) * & + (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*( 1._r8-1._r8/this%psd)-1._r8) * & + this%alpha**this%psd * this%psd * psi**(this%psd-1._r8) + + + dflcdpsi = dnum*den**-1 + -(den**-2)*dden*num + + + + end function dflcdth_from_th_vg + + + + + + + +end module FatesHydroWTFMod From d5bbbd118f27e2c6c42c22932ef18987922bc6bc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 1 Oct 2019 10:19:22 -0700 Subject: [PATCH 034/114] Work on hydro WTFs --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 6 +- biogeophys/FatesHydroWTFMod.F90 | 428 ++++++++++++++++++---- biogeophys/FatesPlantHydraulicsMod.F90 | 90 ++++- main/EDInitMod.F90 | 2 +- main/FatesHydraulicsMemMod.F90 | 19 +- 5 files changed, 465 insertions(+), 80 deletions(-) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index 9b64748d6c..fb37bb09d6 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -45,11 +45,7 @@ module FatesHydroUnitFunctionsMod ! mixing different PV methods, while scientifically interesting ! *may* lead to strange and unstable behavior. - integer, public, parameter :: van_genuchten = 1 - integer, public, parameter :: campbell = 2 - integer, public, parameter :: van_genuchten_eccp = 3 - integer, public, parameter :: campbell_eccp = 4 - integer, public, parameter :: iswc = van_genuchten + logical, public, parameter :: allow_unconstrained_theta = .true. diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index c9dd9cce92..143e8a1ce5 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -22,52 +22,151 @@ module FatesHydroWTFMod ! ------------------------------------------------------------------------------------- ! Generic class that can be extended to describe - ! specific Pedo-transfer Functions + ! specific water retention functions - type, public :: wtf_type + type, public :: wrf_type + procedure :: th_from_psi => wrf_base_func + procedure :: psi_from_th => wrf_base_func + procedure :: dpsidth_from_th => wrf_base_func + procedure :: set_wrf_param => wrf_base_sub + end type wrf_type - ! These base pointers should never be actually called - procedure :: th_from_psi => th_from_psi_base - procedure :: psi_from_th => psi_from_th_base - procedure :: dpsidth_from_th => dpsidth_from_th_base - procedure :: flc_from_th => flc_from_th_base - procedure :: dflc_from_th => dflcdth_from_th_base - procedure :: set_param => set_param_base - end type wtf_type - - ! The Van Genuchten Pedo-transfer functions - type, public, extends(wtf_type) :: wtf_type_vg - - real(r8), allocatable :: alpha ! Inverse air entry parameter - real(r8), allocatable :: psd ! Inverse width of pore size distribution parameter - real(r8), allocatable :: th_sat ! Saturation volumetric water content [m3/m3] - real(r8), allocatable :: th_res ! Residual volumetric water content [m3/m3] - - contains + ! Generic class that can be extended to describe + ! water conductance functions + + type, public :: wkf_type + procedure :: ftc_from_psi => wkf_base_func + procedure :: dftcdpsi_from_psi => wkf_base_func + procedure :: set_wkf_param => wkf_base_sub + end type wkf_type + + ! ===================================================================================== + ! Van Genuchten WTF Definitions + ! ===================================================================================== + + ! Water Retention Function + type, public, extends(wrf_type) :: wrf_type_vg + real(r8) :: alpha ! Inverse air entry parameter + real(r8) :: psd ! Inverse width of pore size distribution parameter + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: th_res ! Residual volumetric water content [m3/m3] + contains procedure :: th_from_psi => th_from_psi_vg procedure :: psi_from_th => psi_from_th_vg procedure :: dpsidth_from_th => dpsidth_from_th_vg - procedure :: flc_from_th => flc_from_th_vg - procedure :: dflc_from_th => dflcdth_from_th_vg - procedure :: set_param => set_param_vg - - end type wtf_type_vg - + procedure :: set_wrf_param => set_wrf_param_vg + end type wrf_type_vg + + ! Water Conductivity Function + type, public, extends(wkf_type) :: wkf_type_vg + real(r8) :: alpha ! Inverse air entry parameter + real(r8) :: psd ! Inverse width of pore size distribution parameter + real(r8) :: tort ! Tortuosity parameter (sometimes "l") + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: th_res ! Residual volumetric water content [m3/m3] + contains + procedure :: ftc_from_psi => ftc_from_psi_vg + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_vg + procedure :: set_wkf_param => set_wkf_param_vg + end type wkf_type_vg + + ! ===================================================================================== + ! Clapp-Hornberger and Campbell (CCH) water retention and conductivity functions + ! ===================================================================================== + + ! Water Retention Function + type, public, extends(wrf_type) :: wrf_type_cch + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] + real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + contains + procedure :: th_from_psi => th_from_psi_cch + procedure :: psi_from_th => psi_from_th_cch + procedure :: dpsidth_from_th => dpsidth_from_th_cch + procedure :: set_wrf_param => set_wrf_param_cch + end type wrf_type_cch + + ! Water Conductivity Function + type, public, extends(wkf_type) :: wkf_type_cch + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] + real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + contains + procedure :: ftc_from_psi => ftc_from_psi_cch + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_cch + procedure :: set_wkf_param => set_wkf_param_cch + end type wkf_type_cch - ! This object holds all of the functions and - ! parameters for the different porous media types - type(pft_type), public, pointer :: wtfs(:) + ! ===================================================================================== + ! Plant-only fractional loss of conductivity from Chrisoffersen et al. (tfs model) + ! ===================================================================================== + + ! Water Conductivity Function + type, public, extends(wkf_type) :: wkf_type_tfs + real(r8) :: p50(maxpft) ! matric potential at 50% conductivity loss [Mpa] + real(r8) :: avuln(maxpft) ! vulnerability curve parameter + real(r8) :: th_sat ! volumetric water content at saturation + real(r8), parameter :: min_ftc = 0.005_r8 + contains + procedure :: ftc_from_psi => ftc_from_psi_tfs + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_tfs + procedure :: set_wkf_param => set_wkf_param_tfs + end type wkf_type_tfs + contains ! ===================================================================================== + ! Functional definitions follow here + ! Start off by writing the base types, which ultimately should never be pointed to. + ! ===================================================================================== + + subroutine wrf_base_sub(this) + class(wrf_type) :: this + write(fates_log(),*) 'The base water retention function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end subroutine wrf_base_ignore + + function wrf_base_func(this) return(ig_val) + class(wrf_type) :: this + real(r8) :: ig_val + write(fates_log(),*) 'The base water retention function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end function wrf_base_func + + subroutine wkf_base_sub(this) + class(wkf_type) :: this + write(fates_log(),*) 'The base water conductivity function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end subroutine wkf_base_ignore + + function wkf_base_func(this) return(ig_val) + class(wkf_type) :: this + real(r8) :: ig_val + write(fates_log(),*) 'The base water conductance function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end function wkf_base_func - subroutine set_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in) + + ! ===================================================================================== + ! Van Genuchten Functions are defined here + ! ===================================================================================== + + + subroutine set_wrf_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in) - class(wtf_type_vg) :: this + class(wrf_type_vg) :: this real(r8), intent(in) :: alpha_in real(r8), intent(in) :: psd_in real(r8), intent(in) :: th_sat_in @@ -79,8 +178,28 @@ subroutine set_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in) this%th_res = th_res_in return - end subroutine set_param_vg - + end subroutine set_wrf_param_vg + + ! ===================================================================================== + + subroutine set_wkf_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in,tort_in) + + class(wkf_type_vg) :: this + real(r8), intent(in) :: alpha_in + real(r8), intent(in) :: psd_in + real(r8), intent(in) :: th_sat_in + real(r8), intent(in) :: th_res_in + real(r8), intent(in) :: tort_in + + this%alpha = alpha_in + this%psd = psd_in + this%th_sat = th_sat_in + this%th_res = th_res_in + this%tort = tort_in + + return + end subroutine set_wkf_param_vg + ! ===================================================================================== function th_from_psi_vg(psi) result(th) @@ -88,7 +207,7 @@ function th_from_psi_vg(psi) result(th) ! Van Genuchten (1980) calculation of volumetric water content (theta) ! from matric potential. - class(wtf_type_vg) :: this + class(wrf_type_vg) :: this real(r8), intent(in) :: psi real(r8) :: satfrac real(r8) :: th @@ -96,7 +215,7 @@ function th_from_psi_vg(psi) result(th) !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m ! Saturation fraction - satfrac = (1._r8 + (this%alpha*psi)**this%psd)**(-1+(1._r8/this%psd)) + satfrac = (1._r8 + (this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) ! convert to volumetric water content th = satfrac*(this%th_sat-this%th_res) + this%th_res @@ -104,16 +223,17 @@ function th_from_psi_vg(psi) result(th) end function th_from_psi_vg ! ===================================================================================== - + function psi_from_th_vg(th) result(psi) ! Van Genuchten (1980) calculation of matric potential from ! volumetric water content (theta). - class(wtf_type_vg) :: this + class(wrf_type_vg) :: this real(r8),intent(in) :: th real(r8) :: psi - real(r8) :: satfrac + real(r8) :: m ! inverse of psd + real(r8) :: satfrac ! saturated fraction !------------------------------------------------------------------------------------ ! saturation fraction is the origial equation in vg 1980, we just @@ -122,8 +242,8 @@ function psi_from_th_vg(th) result(psi) ! ----------------------------------------------------------------------------------- satfrac = (th-this%th_res)/(this%th_sat-this%th_res) - - psi = (1._r8/this%alpha)*(satfrac**(1._r8/(1._r8/this%psd-1._r8)) - 1._r8 )**(1._r8/this%psd) + m = 1._r8/this%psd + psi = (1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m end function psi_from_th_vg @@ -131,12 +251,13 @@ end function psi_from_th_vg function dpsidth_from_th_vg(th) result(dpsidth) - class(wtf_type_vg) :: this + class(wrf_type_vg) :: this real(r8),intent(in) :: th real(r8) :: a1 ! parameter intermediary real(r8) :: m1 ! parameter intermediary real(r8) :: m2 ! parameter intermediary real(r8) :: satfrac ! saturation fraction + real(r8) :: dpsidth ! change in matric potential WRT VWC a1 = 1._r8/this%alpha m1 = 1._r8/this%psd @@ -153,68 +274,243 @@ function dpsidth_from_th_vg(th) result(dpsidth) end function dpsidth_from_th_vg - ! ===================================================================================== - - function flc_from_th_vg(th) result(flc) + function ftc_from_psi_vg(psi) result(ftc) + + class(wkf_type_vg) :: this + real(r8),intent(in) :: psi + real(r8) :: num ! numerator term + real(r8) :: den ! denominator term + real(r8) :: ftc num = (1._r8 - (this%alpha*psi)**(this%psd-1._r8) * & (1._r8 + (this%alpha*psi)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 - den = (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*(1._r8-1._r8/this%psd)) - - flc = num/den + den = (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*(1._r8-1._r8/this%psd)) + ftc = num/den - end function flc_from_th_vg + end function ftc_from_psi_vg ! ==================================================================================== - function dflcdpsi_from_psi_vg(th) result(dflcdpsi) + function dftcdpsi_from_psi_vg(psi) result(dftcdpsi) ! The derivative of the fraction of total conductivity ! Note, this function is fairly complex. To get the derivative ! we brake it into terms, and also into numerator and denominator ! and then differentiate those by parts - class(wtf_type_vg) :: this + class(wkf_type_vg) :: this real(r8),intent(in) :: psi - real(r8) :: t1 ! term 1 in numerator - real(r8) :: t2 ! term 2 in numerator - real(r8) :: dt1 ! derivative of term 1 - real(r8) :: dt2 ! derivative of term 2 - real(r8) :: num ! numerator - real(r8) :: dnum ! derivative of numerator - real(r8) :: den ! denominator - real(r8) :: dden ! derivative of denominator - real(r8) :: dflcdpsi ! change in frac total cond wrt psi - + real(r8) :: t1 ! term 1 in numerator + real(r8) :: t2 ! term 2 in numerator + real(r8) :: dt1 ! derivative of term 1 + real(r8) :: dt2 ! derivative of term 2 + real(r8) :: num ! numerator + real(r8) :: dnum ! derivative of numerator + real(r8) :: den ! denominator + real(r8) :: dden ! derivative of denominator + real(r8) :: dftcdpsi ! change in frac total cond wrt psi t1 = (this%alpha*psi)**(this%psd-1._r8) dt1 = this%alpha**(this%psd-1._r8)*(this%psd-1._r8)*psi**(this%psd-2._r8) t2 = (1._r8 + (this%alpha*psi)**this%psd)**-(1._r8-1._r8/this%psd) - dt2 = -(1._r8-1._r8/this%psd) * (1._r8 + (this%alpha*psi)**this%psd)**(1._r8/this%psd) * this%psd*(this%alpha**psd)*psi**(this%psd-1._r8) + dt2 = -(1._r8-1._r8/this%psd) * & + (1._r8 + (this%alpha*psi)**this%psd)**(1._r8/this%psd) * & + this%psd*(this%alpha**psd)*psi**(this%psd-1._r8) num = (1._r8 - t1*t2)**2._r8 dnum = 2._r8 * (1._r8 - t1*t2) * ( t1*dt2 + t2*dt1 ) - den = (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*( 1._r8-1._r8/this%psd)) - dden = (this%lt*( 1._r8-1._r8/this%psd)) * & - (1._r8 + (this%alpha*psi)**this%psd)**(this%lt*( 1._r8-1._r8/this%psd)-1._r8) * & + den = (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) + dden = (this%tort*( 1._r8-1._r8/this%psd)) * & + (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)-1._r8) * & this%alpha**this%psd * this%psd * psi**(this%psd-1._r8) - dflcdpsi = dnum*den**-1 + -(den**-2)*dden*num + dftcdpsi = dnum*den**-1 + -(den**-2)*dden*num + + end function dftcdpsi_from_psi_vg + + ! ===================================================================================== + ! ===================================================================================== + ! Campbell, Clapp-Hornberger Water Retension Functions + ! ===================================================================================== + ! ===================================================================================== + + subroutine set_wrf_param_cch(this,th_sat_in,psi_sat_in,beta_in) + + class(wrf_type_cch) :: this + real(r8), intent(in) :: th_sat_in + real(r8), intent(in) :: psi_sat_in + real(r8), intent(in) :: beta_in + + this%th_sat = th_sat_in + this%psi_sat = psi_sat_in + this%beta = th_beta_in + + return + end subroutine set_wrf_param_cch + + subroutine set_wkf_param_cch(this,th_sat_in,psi_sat_in,beta_in) + + class(wkf_type_cch) :: this + real(r8), intent(in) :: th_sat_in + real(r8), intent(in) :: psi_sat_in + real(r8), intent(in) :: beta_in + + this%th_sat = th_sat_in + this%psi_sat = psi_sat_in + this%beta = th_beta_in + + return + end subroutine set_wkf_param_cch + + ! ===================================================================================== + + function th_from_psi_cch(psi) result(th) + + class(wrf_type_cch) :: this + real(r8), intent(in) :: psi + real(r8) :: th + real(r8) :: satfrac + + satfrac = (psi/this%psi_sat)**(-1.0_r8/this%beta) + th = satfrac*this%th_sat + end function th_from_psi_cch - end function dflcdth_from_th_vg + ! ===================================================================================== + function psi_from_th_cch(th) result(psi) + + class(wrf_type_cch) :: this + real(r8),intent(in) :: th + real(r8) :: psi + psi = this%psi_sat*(th/this%th_sat)**(-this%beta) + end function psi_from_th_cch + ! ===================================================================================== + function dpsidth_from_th_cch(th) result(dpsidth) + + class(wrf_type_cch) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + + ! Differentiate: + ! psi = this%psi_sat*(th/this%th_sat)**(-this%beta) + + dpsidth = -this%beta*this%psi_sat/this%th_sat * (th/this%th_sat)**(-this%beta-1._r8) + + + end function dpsidth_from_th_cch + + ! ===================================================================================== + + function ftc_from_psi_cch(psi) result(ftc) + + class(wkf_type_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: psi_eff + real(r8) :: ftc + + ! th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) + ! ftc = ((psi/this%psi_sat)**(-1.0_r8/this%beta))**(2._r8*this%beta+3._r8) + ! + ! Prevent super-saturation from generating unreasonable FTCs + + psi_eff = min(psi,this%psi_sat) + + ftc = (psi_eff/this%psi_sat)**(-2._r8-3._r8/this%beta) + + end function ftc_from_th_cch + + ! ==================================================================================== + + function dftcdpsi_from_psi_cch(psi) result(dftcdpsi) + + class(wkf_type_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: dftcdpsi ! change in frac total cond wrt psi + + ! Differentiate: + ! ftc = (psi/this%psi_sat)**(-2._r8-3._r8/this%beta) + + ! Note that if we assume a constant, capped FTC=1.0 + ! at saturation, then the derivative is zero there + if(psi wtf_vg + call wtf_vg%set_param_vg(bc_in% + + + end do + end if + + ! Absorbing roots + if(wtf_code(2)==van_genuchten)then + allocate(wtf_vg) + sites(s)%si_hydr%wtf_plant(aroot_p_media) => wtf_vg + end if + + ! Transporting roots + if(wtf_code(3)==van_genuchten)then + allocate(wtf_vg) + sites(s)%si_hydr%wtf_plant(troot_p_media) => wtf_vg + end if + + ! Stem + if(wtf_code(4)==van_genuchten)then + allocate(wtf_vg) + sites(s)%si_hydr%wtf_plant(stem_p_media) => wtf_vg + end if + + ! Leaf + if(wtf_code(5)==van_genuchten)then + allocate(wtf_vg) + sites(s)%si_hydr%wtf_plant(leaf_p_media) => wtf_vg + end if + + + + + end do end subroutine InitHydrSites diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9613d79957..8b8545ec82 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -408,7 +408,7 @@ subroutine init_patches( nsites, sites, bc_in) ! were set from a call inside of the init_cohorts()->create_cohort() subroutine if (hlm_use_planthydro.eq.itrue) then do s = 1, nsites - sitep => sites(s) + sitep => sites(s) call updateSizeDepRhizHydProps(sitep, bc_in(s)) end do end if diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9949b4c02e..ca55d41d7d 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -3,6 +3,7 @@ module FatesHydraulicsMemMod use FatesConstantsMod, only : r8 => fates_r8 use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use FatesConstantsMod, only : itrue,ifalse + use FatesHydroWTFMod, only : wtf_type implicit none @@ -38,7 +39,9 @@ module FatesHydraulicsMemMod integer, parameter, public :: stem_p_media = 2 integer, parameter, public :: troot_p_media = 3 integer, parameter, public :: aroot_p_media = 4 - integer, parameter, public :: rhiz_p_media = 5 + integer, parameter, public :: n_p_media = 4 ! This is just the number of plant + ! organ porous media types, does + ! not include soil ! This vector holds the identifiers for which porous media type is in the comaprtment integer, parameter, public, dimension(n_hypool_tot) :: porous_media = (/leaf_p_media, & @@ -145,6 +148,14 @@ module FatesHydraulicsMemMod ! Draw from or add to this pool when ! insufficient plant water available to ! support transpiration + + + class(wrf_type), pointer :: wrf_soil(:) ! Water retention function for soil layers +! class(wrf_type), pointer :: wrf_plant(:) ! Water retention function for plant organs + class(wkf_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil +! class(wkf_type), pointer :: wkf_plant(:) ! Water conductivity (K) function for plants + + ! Hold Until Van Genuchten is implemented ! col inverse of air-entry pressure [MPa-1] (for van Genuchten SWC only) @@ -383,6 +394,12 @@ subroutine InitHydrSite(this) this%h2oveg_growturn_err = 0.0_r8 this%h2oveg_pheno_err = 0.0_r8 this%h2oveg_hydro_err = 0.0_r8 + + ! We have separate water transfer functions and parameters + ! for each soil layer, and each plant compartment type + allocate(this%wrf_soil(1:nlevsoil_hyd)) + allocate(this%wkf_soil(1:nlevsoil_hyd)) + end associate From 06496ed296ec0c2b2db6f0e0466f9c7fb10bc0dd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 1 Oct 2019 13:19:11 -0700 Subject: [PATCH 035/114] updates to hydro WTFs --- biogeophys/FatesHydroWTFMod.F90 | 6 ++-- biogeophys/FatesPlantHydraulicsMod.F90 | 41 ++++++++++++++++++++++++-- main/FatesHydraulicsMemMod.F90 | 14 --------- main/FatesInterfaceMod.F90 | 4 ++- 4 files changed, 44 insertions(+), 21 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 143e8a1ce5..236f4df512 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -105,9 +105,9 @@ module FatesHydroWTFMod ! Water Conductivity Function type, public, extends(wkf_type) :: wkf_type_tfs - real(r8) :: p50(maxpft) ! matric potential at 50% conductivity loss [Mpa] - real(r8) :: avuln(maxpft) ! vulnerability curve parameter - real(r8) :: th_sat ! volumetric water content at saturation + real(r8) :: p50 ! matric potential at 50% conductivity loss [Mpa] + real(r8) :: avuln ! vulnerability curve parameter + real(r8) :: th_sat ! volumetric water content at saturation real(r8), parameter :: min_ftc = 0.005_r8 contains procedure :: ftc_from_psi => ftc_from_psi_tfs diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 0ea94273b0..be280e3473 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -159,7 +159,7 @@ module FatesPlantHydraulicsMod integer, public, parameter :: van_genuchten = 1 integer, public, parameter :: campbell = 2 - integer, public, parameter :: cx_eccp = 3 + integer, public, parameter :: tfs = 3 logical,parameter :: debug = .true. !flag to report warning in hydro @@ -175,12 +175,12 @@ module FatesPlantHydraulicsMod ! Define the global object that holds the water retention functions ! for plants of each different porous media type, and plant functional type - type(wrf_type),pointer :: wrf_plant(:,:) + class(wrf_type),pointer :: wrf_plant(:,:) ! Define the global object that holds the water conductance functions ! for plants of each different porous media type, and plant functional type - type(wkf_type), pointer :: wkf_plant(:,:) + class(wkf_type), pointer :: wkf_plant(:,:) ! @@ -217,6 +217,41 @@ module FatesPlantHydraulicsMod contains + subroutine InitHYDROGlobals() + + class(wrf_type_vg) :: wrf_vg + class(wkf_type_vg) :: wkf_vg + class(wrf_type_cch) :: wrf_cch + class(wkf_type_cch) :: wkf_cch + class(wrf_type_tfs) :: wrf_tfs + class(wkf_type_tfs) :: wkf_tfs + + + if(.not.use_ed_planthydraulics) return + + !integer, public, parameter :: van_genuchten = 1 + !integer, public, parameter :: campbell = 2 + !integer, public, parameter :: tfs = 3 + + allocate(wrf_plant(n_p_media,numpft)) + allocate(wkf_plant(n_p_media,numpft)) + + if(plant_wrf_type==van_genuchten)then + + do ft = 1,numpft + do pm = 1, n_p_media + allocate(wrf_vg) + wrf_plant(pm,ft) => wrf_vg + wrf_vg%set_wrf_param( + + end do + end do + + return + end subroutine InitHYDROGlobals + + + !------------------------------------------------------------------------------ subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index ca55d41d7d..afe16e667a 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -151,22 +151,8 @@ module FatesHydraulicsMemMod class(wrf_type), pointer :: wrf_soil(:) ! Water retention function for soil layers -! class(wrf_type), pointer :: wrf_plant(:) ! Water retention function for plant organs class(wkf_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil -! class(wkf_type), pointer :: wkf_plant(:) ! Water conductivity (K) function for plants - - - ! Hold Until Van Genuchten is implemented - ! col inverse of air-entry pressure [MPa-1] (for van Genuchten SWC only) - ! real(r8), allocatable :: alpha_VG(:) - ! col pore-size distribution index [-] (for van Genuchten SWC only) - ! real(r8), allocatable :: n_VG(:) - ! = 1 - 1/n_VG [-] (for van Genuchten SWC only) - ! real(r8), allocatable :: m_VG(:) - ! col pore tortuosity parameter [-] (for van Genuchten SWC only) - ! real(r8), allocatable :: l_VG(:) - contains procedure :: InitHydrSite diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0254c89123..241f35a962 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -619,6 +619,7 @@ module FatesInterfaceMod public :: set_fates_global_elements public :: FatesReportParameters public :: InitPARTEHGlobals + public :: InitHydroGlobals public :: allocate_bcin public :: allocate_bcout @@ -1836,8 +1837,9 @@ subroutine InitPARTEHGlobals() end select + end subroutine InitPARTEHGlobals + - end subroutine InitPARTEHGlobals end module FatesInterfaceMod From 9935a3cda8e8b6e43cb9f756d4e82c5901c6c42d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 1 Oct 2019 15:36:18 -0700 Subject: [PATCH 036/114] hydro WTFs, added unit test wrappers and initialization code in hydro. --- biogeophys/FatesHydroWTFMod.F90 | 6 +- biogeophys/FatesPlantHydraulicsMod.F90 | 227 ++++++++++++------ .../hydro/f90_src/EDParamsHydroMod.F90 | 62 ----- .../hydro/f90_src/HydroUnitWrapMod.F90 | 203 ++++++++++++++++ main/FatesInterfaceMod.F90 | 34 ++- 5 files changed, 389 insertions(+), 143 deletions(-) delete mode 100644 functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 create mode 100644 functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 236f4df512..cbf606ab53 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -336,7 +336,7 @@ end function dftcdpsi_from_psi_vg ! ===================================================================================== ! ===================================================================================== - ! Campbell, Clapp-Hornberger Water Retension Functions + ! Campbell, Clapp-Hornberger Water Retention Functions ! ===================================================================================== ! ===================================================================================== @@ -353,7 +353,9 @@ subroutine set_wrf_param_cch(this,th_sat_in,psi_sat_in,beta_in) return end subroutine set_wrf_param_cch - + + ! ===================================================================================== + subroutine set_wkf_param_cch(this,th_sat_in,psi_sat_in,beta_in) class(wkf_type_cch) :: this diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index be280e3473..d7e7590c63 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -161,6 +161,12 @@ module FatesPlantHydraulicsMod integer, public, parameter :: campbell = 2 integer, public, parameter :: tfs = 3 + integer, parameter :: plant_wrf_type = van_genuchten + integer, parameter :: plant_wkf_type = tfs + integer, parameter :: soil_wrf_type = campbell + integer, parameter :: soil_wkf_type = campbell + + logical,parameter :: debug = .true. !flag to report warning in hydro @@ -182,6 +188,12 @@ module FatesPlantHydraulicsMod class(wkf_type), pointer :: wkf_plant(:,:) + real(r8), parameter :: alpha_vg = 0.001_r8 + real(r8), parameter :: th_sat_vg = 0.65_r8 + real(r8), parameter :: th_res_vg = 0.35_r8 + real(r8), parameter :: psd_vg = 2.7_r8 + real(r8), parameter :: tort_vg = 0.5_r8 + ! ! !PUBLIC MEMBER FUNCTIONS: @@ -219,33 +231,89 @@ module FatesPlantHydraulicsMod subroutine InitHYDROGlobals() - class(wrf_type_vg) :: wrf_vg - class(wkf_type_vg) :: wkf_vg - class(wrf_type_cch) :: wrf_cch - class(wkf_type_cch) :: wkf_cch - class(wrf_type_tfs) :: wrf_tfs - class(wkf_type_tfs) :: wkf_tfs + ! This routine allocates the Water Transfer Functions (WTFs) + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for plants! These functions have specific + ! parameters, potentially, for each plant functional type and + ! each organ (pft x organ), but this can be used globally (across + ! all sites on the node (machine) to save memory. These functions + ! are also applied to soils, but since soil properties vary with + ! soil layer and location, those functions are bound to the site + ! structure, and are therefore not "global". + + ! Define + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_tfs), pointer :: wrf_tfs + class(wkf_type_tfs), pointer :: wkf_tfs if(.not.use_ed_planthydraulics) return - !integer, public, parameter :: van_genuchten = 1 - !integer, public, parameter :: campbell = 2 - !integer, public, parameter :: tfs = 3 - allocate(wrf_plant(n_p_media,numpft)) allocate(wkf_plant(n_p_media,numpft)) - if(plant_wrf_type==van_genuchten)then + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wrf_type) + case(van_genuchten) + do ft = 1,numpft + do pm = 1, n_p_media + allocate(wrf_vg) + wrf_plant(pm,ft) => wrf_vg + wrf_vg%set_wrf_param_vg(alpha_in = alpha_vg, & + psd_in = psd_vg, & + th_sat_in = th_sat_vg, & + th_res_in = th_res_vg) + end do + end do + case(campbell) + write(fates_log(),*) 'campbell/clapp-hornberger retention curves not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs) + write(fates_log(),*) 'TFS water retention curves not yet added to plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wkf_type) + case(van_genuchten) + do ft = 1,numpft + do pm = 1, n_p_media + allocate(wkf_vg) + wkf_plant(pm,ft) => wkf_vg + wkf_vg%set_wkf_param_vg(alpha_in = alpha_vg, & + psd_in = psd_vg, & + th_sat_in = th_sat_vg, & + th_res_in = th_res_vg, & + tort_in = tort_vg) + end do + end do + case(campbell) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs) + do ft = 1,numpft + do pm = 1, n_p_media + allocate(wkf_tfs) + wkf_plant(pm,ft) => wkf_tfs + wkf_tfs%set_wkf_param_tfs(th_sat_in = EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + p50_in = EDPftvarcon_inst%hydr_p50_node(ft,pm), & + avuln_in = EDPftvarcon_inst%hydr_avuln_node(ft,pm)) + end do + end do + end select + - do ft = 1,numpft - do pm = 1, n_p_media - allocate(wrf_vg) - wrf_plant(pm,ft) => wrf_vg - wrf_vg%set_wrf_param( - end do - end do return end subroutine InitHYDROGlobals @@ -1172,8 +1240,12 @@ subroutine InitHydrSites(sites,bc_in,numpft) integer :: nsites integer :: s type(ed_site_hydr_type),pointer :: csite_hydr - class(wtf_type_vg), pointer :: wtf_vg - + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_tfs), pointer :: wrf_tfs + class(wkf_type_tfs), pointer :: wkf_tfs if ( hlm_use_planthydro.eq.ifalse ) return @@ -1205,66 +1277,67 @@ subroutine InitHydrSites(sites,bc_in,numpft) sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil call sites(s)%si_hydr%InitHydrSite() + ! -------------------------------------------------------------------------------- ! Initialize water transfer functions + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for soil! + ! -------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wrf_type) + case(van_genuchten) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_vg) + csite_hydr%wrf_soil(j) => wrf_vg + wrf_vg%set_wrf_param_vg(alpha_in = alpha_vg, & + psd_in = psd_vg, & + th_sat_in = th_sat_vg, & + th_res_in = th_res_vg) + end do + case(campbell) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_vg) + csite_hydr%wrf_soil(j) => wrf_cch + wrf_cch%set_wrf_param_cch(th_sat_in = bc_in(s)%watsat_sisl(j), & + psi_sat_in =(-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + beta_in = bc_in(s)%bsw_sisl(j)) + end do + case(tfs) + write(fates_log(),*) 'TFS water retention curves not available for soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - - ! We will use codes for the different ways to initialize the - ! models. The number refers to the specific hypothesis/form - ! The positions are as follows: - ! 1st: soil water retention function (eg theta vs psi) - ! 2nd: aroot ... - ! 3rd: troot ... - ! 4th: stem ... - ! 5th: leaf ... - - ! integer, public, parameter :: van_genuchten = 1 - ! integer, public, parameter :: campbell = 2 - ! integer, public, parameter :: cx_eccp = 3 - - ! This code assumes VG for all soil and organs, - ! but the Chistoffersen-Xu functions for FLC in plant organs - wtf_code = 1111113333 + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- - ! Set soil properties - if (wtf_code(1)==van_genuchten) then - do j=1,bc_in(s)%nlevsoil - allocate(wtf_vg) - sites(s)%si_hydr%wtf_soil(j) => wtf_vg - call wtf_vg%set_param_vg(bc_in% - - - end do - end if - - ! Absorbing roots - if(wtf_code(2)==van_genuchten)then - allocate(wtf_vg) - sites(s)%si_hydr%wtf_plant(aroot_p_media) => wtf_vg - end if - - ! Transporting roots - if(wtf_code(3)==van_genuchten)then - allocate(wtf_vg) - sites(s)%si_hydr%wtf_plant(troot_p_media) => wtf_vg - end if - - ! Stem - if(wtf_code(4)==van_genuchten)then - allocate(wtf_vg) - sites(s)%si_hydr%wtf_plant(stem_p_media) => wtf_vg - end if - - ! Leaf - if(wtf_code(5)==van_genuchten)then - allocate(wtf_vg) - sites(s)%si_hydr%wtf_plant(leaf_p_media) => wtf_vg - end if - - - - - - end do + select case(soil_wkf_type) + case(van_genuchten) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_vg) + csite_hydr%wkf_soil(j) => wkf_vg + wkf_vg%set_wkf_param_vg(alpha_in = alpha_vg, & + psd_in = psd_vg, & + th_sat_in = th_sat_vg, & + th_res_in = th_res_vg, & + tort_in = th_tort_vg) + end do + case(campbell) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_cch) + csite_hydr%wkf_soil(j) => wkf_cch + wkf_cch%set_wkf_param_cch(th_sat_in = bc_in(s)%watsat_sisl(j), & + psi_sat_in = (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + beta_in = bc_in(s)%bsw_sisl(j)) + end do + case(tfs) + write(fates_log(),*) 'TFS conductance not used in soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + end do end subroutine InitHydrSites diff --git a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 deleted file mode 100644 index 84b31ecf80..0000000000 --- a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 +++ /dev/null @@ -1,62 +0,0 @@ - -! THIS IS A STRIPPED DOWN VERSION OF main/EDParamsMod.F90 - - -module EDParamsMod - ! - ! module that deals with reading the ED parameter file - ! - use iso_c_binding, only : c_char - use iso_c_binding, only : c_int - use FatesConstantsMod, only : r8 => fates_r8 - - implicit none - private - save - - integer(kind=c_int), parameter :: param_string_length = 32 - - - ! Hydraulics Control Parameters - ! ---------------------------------------------------------------------------------------------- - real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface - ! soil to root direction (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" - - real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface - ! root to soil direciton (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" - - real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" - - real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" - - public :: EDParamsPySet - -contains - - subroutine EDParamsPySet(rval,name) - - implicit none - ! Arguments - character(kind=c_char,len=*), intent(in) :: name - real(r8),intent(in) :: rval - - if(trim(name) == trim(hydr_name_psi0))then - hydr_psi0 = rval - elseif(trim(name) == trim(hydr_name_psicap))then - hydr_psicap = rval - else - print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) - stop - end if - - return - end subroutine EDParamsPySet - - - - -end module EDParamsMod diff --git a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 new file mode 100644 index 0000000000..b9f5aee332 --- /dev/null +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -0,0 +1,203 @@ + +! This module holds hydro specific F90 code needed to run the unit tests +! This is stuff that we don't share with other unit tests, whereas UnitWrapMod.F90 +! can be built generically. + +module HydroUnitWrapMod + ! + ! module that deals with reading the ED parameter file + ! + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + use FatesConstantsMod, only : r8 => fates_r8 + use FatesHydroWTFMod, only : wrf_type,wrf_type_vg,wrf_type_cch + use FatesHydroWTFMod, only : wkf_type,wkf_type_vg,wkf_type_cch,wkf_type_tfs + + + implicit none + private + save + + integer(kind=c_int), parameter :: param_string_length = 32 + + integer, public, parameter :: van_genuchten = 1 + integer, public, parameter :: campbell = 2 + integer, public, parameter :: tfs = 3 + + + ! Hydraulics Control Parameters + ! ---------------------------------------------------------------------------------------------- + real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface + ! soil to root direction (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" + + real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface + ! root to soil direciton (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" + + real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" + + real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" + + public :: EDParamsPySet + +contains + + + class(wrf_type), pointer :: wrfs(:) ! This holds all (soil and plant) water retention functions + class(wkf_type), pointer :: wkfs(:) ! + + + subroutine InitAllocWTFs(n_wrfs,n_wkfs) + + + integer,intent(in) :: n_wrfs + integer,intent(in) :: n_wkfs + + allocate(wrfs(n_wrfs)) + allocate(wkfs(n_wkfs)) + + return + end subroutine InitAllocWTFs + + + subroutine SetWRF(index,itype,pvals) + + integer,intent(in) :: index + integer,intent(in) :: itype + real(r8), intent(in) :: pvals(:) + + class(wrf_type_vg), pointer :: wrf_vg + class(wrf_type_cch), pointer :: wrf_cch + + + if(itype == van_genuchten) then + allocate(wrf_vg) + wrfs(index) => wrf_vg + wrf_vg%set_wrf_param_vg(pvals(1),pvals(2),pvals(3),pvals(4)) !alpha,psd,th_sat,th_res + elseif(itype==campbell) then + allocate(wrf_cch) + wrfs(index) => wrf_cch + wrf_cch%set_wrf_param_cch(pvals(1),pvals(2),pvals(3)) !th_sat,psi_sat,beta + else + print*,"UNKNOWN WRF" + stop + end if + + return + end subroutine SetWRF + + subroutine SetWKF(index,itype,pvals) + + integer,intent(in) :: index + integer,intent(in) :: itype + real(r8), intent(in) :: pvals(:) + + class(wkf_type_vg), pointer :: wkf_vg + class(wkf_type_cch), pointer :: wkf_cch + + + if(itype == van_genuchten) then + allocate(wkf_vg) + wkfs(index) => wkf_vg + wkf_vg%set_wkf_param_vg(pvals(1),pvals(2),pvals(3),pvals(4),pvals(5)) !alpha,psd,th_sat,th_res,tort + elseif(itype==campbell) then + allocate(wkf_cch) + wkfs(index) => wkf_cch + wkf_cch%set_wkf_param_cch(pvals(1),pvals(2),pvals(3)) !th_sat,psi_sat,beta + elseif(itype==tfs) then + allocate(wkf_tfs) + wkfs(index) => wkf_tfs + wkf_tfs%set_wkf_param_tfs(pvals(1),pvals(2),pvals(3)) !th_sat,p50,avuln + else + print*,"UNKNOWN WKF" + stop + end if + + return + end subroutine SetWRF + + + function WrapTHFromPSI(index,psi) result(th) + + integer, intent(in) :: index + real(r8),intent(in) :: psi + real(r8) :: th + + th = wrfs(index)%th_from_psi(psi) + + return + end function WrapTHFromPSI + + + function WrapPSIFromTH(index,th) result(psi) + + integer, intent(in) :: index + real(r8),intent(in) :: th + real(r8) :: psi + + psi = wrfs(index)%psi_from_th(th) + + end function WrapPSIFromTH + + + function WrapDPSIDTH(index,th) result(dpsidth) + + integer, intent(in) :: index + real(r8),intent(in) :: th + real(r8) :: dpsidth + + dpsidth = wrfs(index)%dpsidth_from_th(th) + + end function WrapDPSIDTH + + + function WrapDFTCDPSI(index,psi) result(dftcdpsi) + + integer, intent(in) :: index + real(r8),intent(in) :: psi + real(r8) :: dftcdpsi + + dftcdth = wrfs(index)%dftcdth_from_psi(psi) + + end function WrapDFTCDPSI + + + function WrapFTCFromPSI(index,psi) result(ftc) + + integer, intent(in) :: index + real(r8),intent(in) :: psi + real(r8) :: ftc + + ftc = wrfs(index)%ftc_from_psi(psi) + + return + end function WrapFTCFromPSI + + + + subroutine EDParamsPySet(rval,name) + + implicit none + ! Arguments + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + + if(trim(name) == trim(hydr_name_psi0))then + hydr_psi0 = rval + elseif(trim(name) == trim(hydr_name_psicap))then + hydr_psicap = rval + else + print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) + stop + end if + + return + end subroutine EDParamsPySet + + + + +end module HydroUnitWrapMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 241f35a962..4b292f116a 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -618,8 +618,7 @@ module FatesInterfaceMod public :: SetFatesTime public :: set_fates_global_elements public :: FatesReportParameters - public :: InitPARTEHGlobals - public :: InitHydroGlobals + public :: InitFatesGlobals public :: allocate_bcin public :: allocate_bcout @@ -1789,6 +1788,37 @@ end subroutine FatesReportParameters ! ==================================================================================== + subroutine InitFatesGlobals(masterproc) + + ! -------------------------------------------------------------------------- + ! This subroutine is simply a wrapper that calls various FATES modules + ! that initialize global objects, things, constructs, etc. Globals only + ! need to be set once during initialization, for each machine, and this + ! should not be called for forked SMP processes. + ! -------------------------------------------------------------------------- + + logical,intent(in) :: is_master ! This is useful for reporting + ! and diagnostics so info is not printed + ! on numerous nodes to standard out. This + ! is not used to filter which machines + ! (nodes) to run these procedures, they + ! should be run on ALL nodes. + + ! Initialize PARTEH globals + ! (like the element lists, and mapping tables) + call InitPARTEHGlobals() + + ! Initialize Hydro globals + ! (like water retention functions) + call InitHydroGlobals() + + + return + end subroutine InitFatesGlobals + + ! ==================================================================================== + + subroutine InitPARTEHGlobals() ! Initialize the Plant Allocation and Reactive Transport From 59d80bdbe4a5f17db02a75a2fb9ef098cca9a166 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 7 Oct 2019 13:27:01 -0700 Subject: [PATCH 037/114] Updated hydro unit tests to accomodate new wtf structures. --- biogeophys/FatesHydroUnitFunctionsMod.F90 | 1 + biogeophys/FatesHydroWTFMod.F90 | 239 ++++++++++-------- .../hydro/HydroUTestDriver.py | 91 +++++-- functional_unit_testing/hydro/bld/README | 0 .../hydro/build_hydro_f90_objects.sh | 8 +- .../hydro/f90_src/HydroUnitWrapMod.F90 | 110 ++++---- parteh/PRTGenericMod.F90 | 22 +- 7 files changed, 269 insertions(+), 202 deletions(-) delete mode 100644 functional_unit_testing/hydro/bld/README diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90 index fb37bb09d6..96c564b84a 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90 @@ -15,6 +15,7 @@ module FatesHydroUnitFunctionsMod use FatesConstantsMod, only : grav_earth use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : pi_const + use use EDPftvarcon, only : pft_p => EDPftvarcon_inst use EDParamsMod, only : hydr_psi0 use EDParamsMod, only : hydr_psicap diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index cbf606ab53..db70f96695 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -10,7 +10,10 @@ module FatesHydroWTFMod use FatesConstantsMod, only : grav_earth use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : pi_const - + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private @@ -21,14 +24,22 @@ module FatesHydroWTFMod ! may be applied to xylems, stems, etc, they are not limited to soils (pedo). ! ------------------------------------------------------------------------------------- + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + real(r8), parameter :: min_ftc = 0.005_r8 + + ! Generic class that can be extended to describe ! specific water retention functions type, public :: wrf_type - procedure :: th_from_psi => wrf_base_func - procedure :: psi_from_th => wrf_base_func - procedure :: dpsidth_from_th => wrf_base_func - procedure :: set_wrf_param => wrf_base_sub + contains + procedure :: th_from_psi => th_from_psi_base + procedure :: psi_from_th => psi_from_th_base + procedure :: dpsidth_from_th => dpsidth_from_th_base + procedure :: set_wrf_param => set_wrf_param_base end type wrf_type @@ -36,9 +47,10 @@ module FatesHydroWTFMod ! water conductance functions type, public :: wkf_type - procedure :: ftc_from_psi => wkf_base_func - procedure :: dftcdpsi_from_psi => wkf_base_func - procedure :: set_wkf_param => wkf_base_sub + contains + procedure :: ftc_from_psi => ftc_from_psi_base + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_base + procedure :: set_wkf_param => set_wkf_param_base end type wkf_type @@ -67,9 +79,9 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] contains - procedure :: ftc_from_psi => ftc_from_psi_vg - procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_vg - procedure :: set_wkf_param => set_wkf_param_vg + procedure :: ftc_from_psi => ftc_from_psi_vg + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_vg + procedure :: set_wkf_param => set_wkf_param_vg end type wkf_type_vg ! ===================================================================================== @@ -108,14 +120,13 @@ module FatesHydroWTFMod real(r8) :: p50 ! matric potential at 50% conductivity loss [Mpa] real(r8) :: avuln ! vulnerability curve parameter real(r8) :: th_sat ! volumetric water content at saturation - real(r8), parameter :: min_ftc = 0.005_r8 + contains procedure :: ftc_from_psi => ftc_from_psi_tfs procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_tfs procedure :: set_wkf_param => set_wkf_param_tfs end type wkf_type_tfs - contains @@ -123,86 +134,115 @@ module FatesHydroWTFMod ! Functional definitions follow here ! Start off by writing the base types, which ultimately should never be pointed to. ! ===================================================================================== +! procedure :: th_from_psi => th_from_psi +! procedure :: psi_from_th => psi_from_th +! procedure :: dpsidth_from_th => dpsidth_from_th +! procedure :: set_wrf_param => set_wrf_param +! +! procedure :: set_wkf_param => set_wkf_param + - subroutine wrf_base_sub(this) - class(wrf_type) :: this + subroutine set_wrf_param_base(this,params_in) + class(wrf_type) :: this + real(r8),intent(in) :: params_in(:) write(fates_log(),*) 'The base water retention function' write(fates_log(),*) 'should never be actualized' write(fates_log(),*) 'check how the class pointer was setup' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end subroutine wrf_base_ignore - - function wrf_base_func(this) return(ig_val) - class(wrf_type) :: this - real(r8) :: ig_val + call endrun(msg=errMsg(sourcefile, __LINE__)) + end subroutine set_wrf_param_base + subroutine set_wkf_param_base(this,params_in) + class(wkf_type) :: this + real(r8),intent(in) :: params_in(:) write(fates_log(),*) 'The base water retention function' write(fates_log(),*) 'should never be actualized' write(fates_log(),*) 'check how the class pointer was setup' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end function wrf_base_func - - subroutine wkf_base_sub(this) - class(wkf_type) :: this - write(fates_log(),*) 'The base water conductivity function' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end subroutine set_wkf_param_base + function th_from_psi_base(this,psi) result(th) + class(wrf_type) :: this + real(r8),intent(in) :: psi + real(r8) :: th + write(fates_log(),*) 'The base water retention function' write(fates_log(),*) 'should never be actualized' write(fates_log(),*) 'check how the class pointer was setup' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end subroutine wkf_base_ignore - - function wkf_base_func(this) return(ig_val) - class(wkf_type) :: this - real(r8) :: ig_val - write(fates_log(),*) 'The base water conductance function' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end function th_from_psi_base + function psi_from_th_base(this,th) result(psi) + class(wrf_type) :: this + real(r8),intent(in) :: th + real(r8) :: psi + write(fates_log(),*) 'The base water retention function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end function psi_from_th_base + function dpsidth_from_th_base(this,th) result(dpsidth) + class(wrf_type) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + write(fates_log(),*) 'The base water retention function' write(fates_log(),*) 'should never be actualized' write(fates_log(),*) 'check how the class pointer was setup' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end function wkf_base_func + call endrun(msg=errMsg(sourcefile, __LINE__)) + end function dpsidth_from_th_base + function ftc_from_psi_base(this,psi) result(ftc) + class(wkf_type) :: this + real(r8),intent(in) :: psi + real(r8) :: ftc + write(fates_log(),*) 'The base water retention function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end function ftc_from_psi_base + function dftcdpsi_from_psi_base(this,psi) result(dftcdpsi) + class(wkf_type) :: this + real(r8),intent(in) :: psi + real(r8) :: dftcdpsi + write(fates_log(),*) 'The base water retention function' + write(fates_log(),*) 'should never be actualized' + write(fates_log(),*) 'check how the class pointer was setup' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end function dftcdpsi_from_psi_base - ! ===================================================================================== ! Van Genuchten Functions are defined here ! ===================================================================================== - - subroutine set_wrf_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in) + subroutine set_wrf_param_vg(this,params_in) class(wrf_type_vg) :: this - real(r8), intent(in) :: alpha_in - real(r8), intent(in) :: psd_in - real(r8), intent(in) :: th_sat_in - real(r8), intent(in) :: th_res_in - - this%alpha = alpha_in - this%psd = psd_in - this%th_sat = th_sat_in - this%th_res = th_res_in + real(r8), intent(in) :: params_in(:) + + this%alpha = params_in(1) + this%psd = params_in(2) + this%th_sat = params_in(3) + this%th_res = params_in(4) + + print*,this%alpha,this%psd,this%th_sat,this%th_res + return end subroutine set_wrf_param_vg ! ===================================================================================== - subroutine set_wkf_param_vg(this,alpha_in,psd_in,th_sat_in,th_res_in,tort_in) + subroutine set_wkf_param_vg(this,params_in) class(wkf_type_vg) :: this - real(r8), intent(in) :: alpha_in - real(r8), intent(in) :: psd_in - real(r8), intent(in) :: th_sat_in - real(r8), intent(in) :: th_res_in - real(r8), intent(in) :: tort_in - - this%alpha = alpha_in - this%psd = psd_in - this%th_sat = th_sat_in - this%th_res = th_res_in - this%tort = tort_in + real(r8), intent(in) :: params_in(:) + + this%alpha = params_in(1) + this%psd = params_in(2) + this%th_sat = params_in(3) + this%th_res = params_in(4) + this%tort = params_in(5) return end subroutine set_wkf_param_vg ! ===================================================================================== - function th_from_psi_vg(psi) result(th) + function th_from_psi_vg(this,psi) result(th) ! Van Genuchten (1980) calculation of volumetric water content (theta) ! from matric potential. @@ -224,7 +264,7 @@ end function th_from_psi_vg ! ===================================================================================== - function psi_from_th_vg(th) result(psi) + function psi_from_th_vg(this,th) result(psi) ! Van Genuchten (1980) calculation of matric potential from ! volumetric water content (theta). @@ -242,6 +282,10 @@ function psi_from_th_vg(th) result(psi) ! ----------------------------------------------------------------------------------- satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + + print*,"sf: ",satfrac + stop + m = 1._r8/this%psd psi = (1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m @@ -249,7 +293,7 @@ end function psi_from_th_vg ! ===================================================================================== - function dpsidth_from_th_vg(th) result(dpsidth) + function dpsidth_from_th_vg(this,th) result(dpsidth) class(wrf_type_vg) :: this real(r8),intent(in) :: th @@ -276,7 +320,7 @@ end function dpsidth_from_th_vg ! ===================================================================================== - function ftc_from_psi_vg(psi) result(ftc) + function ftc_from_psi_vg(this,psi) result(ftc) class(wkf_type_vg) :: this real(r8),intent(in) :: psi @@ -294,8 +338,7 @@ end function ftc_from_psi_vg ! ==================================================================================== - function dftcdpsi_from_psi_vg(psi) result(dftcdpsi) - + function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) ! The derivative of the fraction of total conductivity ! Note, this function is fairly complex. To get the derivative @@ -316,10 +359,10 @@ function dftcdpsi_from_psi_vg(psi) result(dftcdpsi) t1 = (this%alpha*psi)**(this%psd-1._r8) dt1 = this%alpha**(this%psd-1._r8)*(this%psd-1._r8)*psi**(this%psd-2._r8) - t2 = (1._r8 + (this%alpha*psi)**this%psd)**-(1._r8-1._r8/this%psd) + t2 = (1._r8 + (this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) dt2 = -(1._r8-1._r8/this%psd) * & (1._r8 + (this%alpha*psi)**this%psd)**(1._r8/this%psd) * & - this%psd*(this%alpha**psd)*psi**(this%psd-1._r8) + this%psd*(this%alpha**this%psd)*psi**(this%psd-1._r8) num = (1._r8 - t1*t2)**2._r8 dnum = 2._r8 * (1._r8 - t1*t2) * ( t1*dt2 + t2*dt1 ) @@ -330,7 +373,7 @@ function dftcdpsi_from_psi_vg(psi) result(dftcdpsi) this%alpha**this%psd * this%psd * psi**(this%psd-1._r8) - dftcdpsi = dnum*den**-1 + -(den**-2)*dden*num + dftcdpsi = dnum*den**(-1._r8) - (den**(-2._r8))*dden*num end function dftcdpsi_from_psi_vg @@ -340,39 +383,36 @@ end function dftcdpsi_from_psi_vg ! ===================================================================================== ! ===================================================================================== - subroutine set_wrf_param_cch(this,th_sat_in,psi_sat_in,beta_in) + subroutine set_wrf_param_cch(this,params_in) class(wrf_type_cch) :: this - real(r8), intent(in) :: th_sat_in - real(r8), intent(in) :: psi_sat_in - real(r8), intent(in) :: beta_in + real(r8), intent(in) :: params_in(:) - this%th_sat = th_sat_in - this%psi_sat = psi_sat_in - this%beta = th_beta_in + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) return end subroutine set_wrf_param_cch ! ===================================================================================== - subroutine set_wkf_param_cch(this,th_sat_in,psi_sat_in,beta_in) + subroutine set_wkf_param_cch(this,params_in) class(wkf_type_cch) :: this - real(r8), intent(in) :: th_sat_in - real(r8), intent(in) :: psi_sat_in - real(r8), intent(in) :: beta_in + real(r8), intent(in) :: params_in(:) + - this%th_sat = th_sat_in - this%psi_sat = psi_sat_in - this%beta = th_beta_in + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) return end subroutine set_wkf_param_cch ! ===================================================================================== - function th_from_psi_cch(psi) result(th) + function th_from_psi_cch(this,psi) result(th) class(wrf_type_cch) :: this real(r8), intent(in) :: psi @@ -387,7 +427,7 @@ end function th_from_psi_cch ! ===================================================================================== - function psi_from_th_cch(th) result(psi) + function psi_from_th_cch(this,th) result(psi) class(wrf_type_cch) :: this real(r8),intent(in) :: th @@ -399,7 +439,7 @@ end function psi_from_th_cch ! ===================================================================================== - function dpsidth_from_th_cch(th) result(dpsidth) + function dpsidth_from_th_cch(this,th) result(dpsidth) class(wrf_type_cch) :: this real(r8),intent(in) :: th @@ -415,9 +455,9 @@ end function dpsidth_from_th_cch ! ===================================================================================== - function ftc_from_psi_cch(psi) result(ftc) + function ftc_from_psi_cch(this,psi) result(ftc) - class(wkf_type_cch) :: this + class(wkf_type_cch) :: this real(r8),intent(in) :: psi real(r8) :: psi_eff real(r8) :: ftc @@ -431,13 +471,13 @@ function ftc_from_psi_cch(psi) result(ftc) ftc = (psi_eff/this%psi_sat)**(-2._r8-3._r8/this%beta) - end function ftc_from_th_cch + end function ftc_from_psi_cch ! ==================================================================================== - function dftcdpsi_from_psi_cch(psi) result(dftcdpsi) + function dftcdpsi_from_psi_cch(this,psi) result(dftcdpsi) - class(wkf_type_cch) :: this + class(wkf_type_cch) :: this real(r8),intent(in) :: psi real(r8) :: dftcdpsi ! change in frac total cond wrt psi @@ -461,27 +501,24 @@ end function dftcdpsi_from_psi_cch ! Fractional loss of conductivity via TFS style functions ! ===================================================================================== - subroutine set_wkf_param_tfs(this,th_sat_in,p50_in,avuln_in) + subroutine set_wkf_param_tfs(this,params_in) class(wkf_type_tfs) :: this - real(r8), intent(in) :: th_sat_in - real(r8), intent(in) :: p50_in - real(r8), intent(in) :: avuln_in + real(r8), intent(in) :: params_in(:) - this%th_sat = th_sat_in - this%p50 = p50_in - this%avuln = avuln_in + this%th_sat = params_in(1) + this%p50 = params_in(2) + this%avuln = params_in(3) return end subroutine set_wkf_param_tfs ! ===================================================================================== - function ftc_from_psi_tfs(psi) result(ftc) + function ftc_from_psi_tfs(this,psi) result(ftc) class(wkf_type_tfs) :: this real(r8),intent(in) :: psi ! - integer,intent(in) :: ft ! plant functional type index real(r8) :: ftc ftc = max(min_ftc,1._r8/(1._r8 + (psi/this%p50)**this%avuln)) @@ -490,7 +527,7 @@ end function ftc_from_psi_tfs ! ==================================================================================== - function dftcdpsi_from_psi_tfs(psi) result(dftcdpsi) + function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) class(wkf_type_tfs) :: this real(r8),intent(in) :: psi diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index cf37b454f5..ff3406533e 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -26,13 +26,11 @@ from operator import add - - - CDLParse = imp.load_source('CDLParse','../shared/py_src/CDLParse.py') F90ParamParse = imp.load_source('F90ParamParse','../shared/py_src/F90ParamParse.py') PyF90Utils = imp.load_source('PyF90Utils','../shared/py_src/PyF90Utils.py') + from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type from F90ParamParse import f90_param_type, GetSymbolUsage, GetPFTParmFileSymbols, MakeListUnique from PyF90Utils import c8, ci, cchar @@ -42,21 +40,37 @@ f90_edparams_obj = ctypes.CDLL('bld/EDParamsHydroMod.o',mode=ctypes.RTLD_GLOBAL) f90_constants_obj = ctypes.CDLL('bld/FatesConstantsMod.o',mode=ctypes.RTLD_GLOBAL) f90_unitwrap_obj = ctypes.CDLL('bld/UnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) -f90_hydrofuncs_obj = ctypes.CDLL('bld/FatesHydroUnitFunctionsMod.o',mode=ctypes.RTLD_GLOBAL) +#f90_hydrofuncs_obj = ctypes.CDLL('bld/FatesHydroUnitFunctionsMod.o',mode=ctypes.RTLD_GLOBAL) +f90_wftfuncs_obj = ctypes.CDLL('bld/FatesHydroWTFMod.o',mode=ctypes.RTLD_GLOBAL) +f90_hydrounitwrap_obj = ctypes.CDLL('bld/HydroUnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) # Alias the F90 functions, specify the return type # ----------------------------------------------------------------------------------- -psi_from_th = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_psi_from_th -psi_from_th.restype = c_double +#psi_from_th = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_psi_from_th +#psi_from_th.restype = c_double -dpsidth_from_th= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dpsidth_from_th -dpsidth_from_th.restype = c_double +#dpsidth_from_th= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dpsidth_from_th +#dpsidth_from_th.restype = c_double + +#flc_from_psi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_flc_from_psi +#flc_from_psi.restype = c_double -flc_from_psi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_flc_from_psi -flc_from_psi.restype = c_double +#dflcdpsi_from_psi= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dflcdpsi_from_psi +#dflcdpsi_from_psi.restype = c_double -dflcdpsi_from_psi= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dflcdpsi_from_psi -dflcdpsi_from_psi.restype = c_double +initalloc_wtfs = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_initallocwtfs +setwrf = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_setwrf +setwkf = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_setwkf +th_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapthfrompsi +th_from_psi.restype = c_double +psi_from_th = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrappsifromth +psi_from_th.restype = c_double +dpsidth_from_th = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapdpsidth +dpsidth_from_th.restype = c_double +ftc_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapftcfrompsi +ftc_from_psi.restype = c_double +dftcdpsi_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapftcfrompsi +dftcdpsi_from_psi.restype = c_double #solutepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_solutepsi #pressurepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_pressurepsi @@ -192,23 +206,52 @@ def main(argv): # Push the scalar params data to fortran - iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psi0'].data[0]), \ - c_char_p(scalarparms['hydr_psi0'].symbol.strip()), \ - c_long(len(scalarparms['hydr_psi0'].symbol.strip()))) + #iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psi0'].data[0]), \ + # c_char_p(scalarparms['hydr_psi0'].symbol.strip()), \ + # c_long(len(scalarparms['hydr_psi0'].symbol.strip()))) - iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psicap'].data[0]), \ - c_char_p(scalarparms['hydr_psicap'].symbol.strip()), \ - c_long(len(scalarparms['hydr_psicap'].symbol.strip()))) + #iret = f90_edparams_obj.__edparamsmod_MOD_edparamspyset(c8(scalarparms['hydr_psicap'].data[0]), \ + # c_char_p(scalarparms['hydr_psicap'].symbol.strip()), \ + # c_long(len(scalarparms['hydr_psicap'].symbol.strip()))) # Initialize local objects in the unit test - iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_initallocateplantmedia(ci(4)) - iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(1),c8(rwcft[0]),c8(rwccap[0])) - iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(2),c8(rwcft[1]),c8(rwccap[1])) - iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(3),c8(rwcft[2]),c8(rwccap[2])) - iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(4),c8(rwcft[3]),c8(rwccap[3])) + #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_initallocateplantmedia(ci(4)) + #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(1),c8(rwcft[0]),c8(rwccap[0])) + #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(2),c8(rwcft[1]),c8(rwccap[1])) + #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(3),c8(rwcft[2]),c8(rwccap[2])) + #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(4),c8(rwcft[3]),c8(rwccap[3])) + + npts = 1000 + + iret = initalloc_wtfs(ci(1),ci(1)) + + print('Allocated') +# code.interact(local=dict(globals(), **locals())) + init_wrf_args = (4 * c_double)(0.001,2.7,0.65,0.35) # alpha, psd, th_sat, th_res + iret = setwrf(ci(1),ci(1),ci(4),byref(init_wrf_args)) + print('initialized WRF') + + init_wkf_args = (5 * c_double)(0.001,2.7,0.65,0.35,0.5) + iret = setwkf(ci(1),ci(1),ci(5),byref(init_wkf_args)) + + + stem_theta = np.linspace(0.35, 0.65, num=npts) + stem_psi = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) + + for i,th in enumerate(stem_theta): + stem_psi[i] = psi_from_th(ci(1),c8(th)) + + + fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) + ax1.plot(stem_theta,stem_psi,label='stem vg') + + plt.show() + + + exit(0) # Test 1 For a set of thetas, calculate psi for each pm. @@ -217,7 +260,7 @@ def main(argv): pft1 = 1 pft2 = 2 - npts = 1000 + if(unconstrained): min_leaf_theta = 0.01 diff --git a/functional_unit_testing/hydro/bld/README b/functional_unit_testing/hydro/bld/README deleted file mode 100644 index e69de29bb2..0000000000 diff --git a/functional_unit_testing/hydro/build_hydro_f90_objects.sh b/functional_unit_testing/hydro/build_hydro_f90_objects.sh index ad934d4d77..13bd7d0432 100755 --- a/functional_unit_testing/hydro/build_hydro_f90_objects.sh +++ b/functional_unit_testing/hydro/build_hydro_f90_objects.sh @@ -51,11 +51,15 @@ python AutoGenVarCon.py ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o f90_src/FatesConstantsMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 + ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/UnitWrapMod.o f90_src/UnitWrapMod.F90 -${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroWTFMod.o ../../biogeophys/FatesHydroWTFMod.F90 + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/HydroUnitWrapMod.o f90_src/HydroUnitWrapMod.F90 -${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroUnitFunctionsMod.o ../../biogeophys/FatesHydroUnitFunctionsMod.F90 +#${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroUnitFunctionsMod.o ../../biogeophys/FatesHydroUnitFunctionsMod.F90 diff --git a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 index b9f5aee332..5ef1c410c2 100644 --- a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -10,12 +10,13 @@ module HydroUnitWrapMod use iso_c_binding, only : c_char use iso_c_binding, only : c_int use FatesConstantsMod, only : r8 => fates_r8 + use FatesHydroWTFMod, only : wrf_type,wrf_type_vg,wrf_type_cch use FatesHydroWTFMod, only : wkf_type,wkf_type_vg,wkf_type_cch,wkf_type_tfs implicit none - private + public save integer(kind=c_int), parameter :: param_string_length = 32 @@ -25,34 +26,28 @@ module HydroUnitWrapMod integer, public, parameter :: tfs = 3 - ! Hydraulics Control Parameters - ! ---------------------------------------------------------------------------------------------- - real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface - ! soil to root direction (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" + type wrf_arr_type + class(wrf_type), pointer :: wrf_obj + end type wrf_arr_type - real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface - ! root to soil direciton (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" - - real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" + type wkf_arr_type + class(wkf_type), pointer :: wkf_obj + end type wkf_arr_type - real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" - public :: EDParamsPySet - -contains +! IMPLEMENT THE ARR TYPE RYAN + class(wrf_arr_type), public, pointer :: wrfs(:) ! This holds all (soil and plant) water retention functions + class(wkf_arr_type), public, pointer :: wkfs(:) ! - class(wrf_type), pointer :: wrfs(:) ! This holds all (soil and plant) water retention functions - class(wkf_type), pointer :: wkfs(:) ! +! class(wrf_type), public, pointer :: wrfs(:) +! class(wkf_type), public, pointer :: wkfs(:) + +contains subroutine InitAllocWTFs(n_wrfs,n_wkfs) - integer,intent(in) :: n_wrfs integer,intent(in) :: n_wkfs @@ -63,24 +58,31 @@ subroutine InitAllocWTFs(n_wrfs,n_wkfs) end subroutine InitAllocWTFs - subroutine SetWRF(index,itype,pvals) + + subroutine SetWRF(index,itype,npvals,pvals) + + ! The unit testing frameworks don't like assumed shape + ! array arguments integer,intent(in) :: index integer,intent(in) :: itype - real(r8), intent(in) :: pvals(:) + integer,intent(in) :: npvals + real(r8), intent(in) :: pvals(npvals) class(wrf_type_vg), pointer :: wrf_vg class(wrf_type_cch), pointer :: wrf_cch + print*,"ALLOCATING WRF",index,itype + print*,pvals if(itype == van_genuchten) then allocate(wrf_vg) - wrfs(index) => wrf_vg - wrf_vg%set_wrf_param_vg(pvals(1),pvals(2),pvals(3),pvals(4)) !alpha,psd,th_sat,th_res + wrfs(index)%wrf_obj => wrf_vg + call wrf_vg%set_wrf_param(pvals) !alpha,psd,th_sat,th_res elseif(itype==campbell) then allocate(wrf_cch) - wrfs(index) => wrf_cch - wrf_cch%set_wrf_param_cch(pvals(1),pvals(2),pvals(3)) !th_sat,psi_sat,beta + wrfs(index)%wrf_obj => wrf_cch + call wrf_cch%set_wrf_param(pvals) !th_sat,psi_sat,beta else print*,"UNKNOWN WRF" stop @@ -89,35 +91,36 @@ subroutine SetWRF(index,itype,pvals) return end subroutine SetWRF - subroutine SetWKF(index,itype,pvals) + subroutine SetWKF(index,itype,npvals,pvals) integer,intent(in) :: index integer,intent(in) :: itype - real(r8), intent(in) :: pvals(:) + integer,intent(in) :: npvals + real(r8), intent(in) :: pvals(npvals) class(wkf_type_vg), pointer :: wkf_vg class(wkf_type_cch), pointer :: wkf_cch - + class(wkf_type_tfs), pointer :: wkf_tfs if(itype == van_genuchten) then allocate(wkf_vg) - wkfs(index) => wkf_vg - wkf_vg%set_wkf_param_vg(pvals(1),pvals(2),pvals(3),pvals(4),pvals(5)) !alpha,psd,th_sat,th_res,tort - elseif(itype==campbell) then + wkfs(index)%wkf_obj => wkf_vg + call wkf_vg%set_wkf_param(pvals) !alpha,psd,th_sat,th_res,tort + elseif(itype==campbell) then allocate(wkf_cch) - wkfs(index) => wkf_cch - wkf_cch%set_wkf_param_cch(pvals(1),pvals(2),pvals(3)) !th_sat,psi_sat,beta + wkfs(index)%wkf_obj => wkf_cch + call wkf_cch%set_wkf_param(pvals) !th_sat,psi_sat,beta elseif(itype==tfs) then allocate(wkf_tfs) - wkfs(index) => wkf_tfs - wkf_tfs%set_wkf_param_tfs(pvals(1),pvals(2),pvals(3)) !th_sat,p50,avuln + wkfs(index)%wkf_obj => wkf_tfs + call wkf_tfs%set_wkf_param(pvals) !th_sat,p50,avuln else print*,"UNKNOWN WKF" stop end if return - end subroutine SetWRF + end subroutine SetWKF function WrapTHFromPSI(index,psi) result(th) @@ -126,7 +129,7 @@ function WrapTHFromPSI(index,psi) result(th) real(r8),intent(in) :: psi real(r8) :: th - th = wrfs(index)%th_from_psi(psi) + th = wrfs(index)%wrf_obj%th_from_psi(psi) return end function WrapTHFromPSI @@ -138,7 +141,7 @@ function WrapPSIFromTH(index,th) result(psi) real(r8),intent(in) :: th real(r8) :: psi - psi = wrfs(index)%psi_from_th(th) + psi = wrfs(index)%wrf_obj%psi_from_th(th) end function WrapPSIFromTH @@ -149,7 +152,7 @@ function WrapDPSIDTH(index,th) result(dpsidth) real(r8),intent(in) :: th real(r8) :: dpsidth - dpsidth = wrfs(index)%dpsidth_from_th(th) + dpsidth = wrfs(index)%wrf_obj%dpsidth_from_th(th) end function WrapDPSIDTH @@ -160,7 +163,7 @@ function WrapDFTCDPSI(index,psi) result(dftcdpsi) real(r8),intent(in) :: psi real(r8) :: dftcdpsi - dftcdth = wrfs(index)%dftcdth_from_psi(psi) + dftcdpsi = wkfs(index)%wkf_obj%dftcdpsi_from_psi(psi) end function WrapDFTCDPSI @@ -171,33 +174,10 @@ function WrapFTCFromPSI(index,psi) result(ftc) real(r8),intent(in) :: psi real(r8) :: ftc - ftc = wrfs(index)%ftc_from_psi(psi) + ftc = wkfs(index)%wkf_obj%ftc_from_psi(psi) return end function WrapFTCFromPSI - - - subroutine EDParamsPySet(rval,name) - - implicit none - ! Arguments - character(kind=c_char,len=*), intent(in) :: name - real(r8),intent(in) :: rval - - if(trim(name) == trim(hydr_name_psi0))then - hydr_psi0 = rval - elseif(trim(name) == trim(hydr_name_psicap))then - hydr_psicap = rval - else - print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) - stop - end if - - return - end subroutine EDParamsPySet - - - end module HydroUnitWrapMod diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 76e45336b1..fd43c574df 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -33,6 +33,9 @@ module PRTGenericMod implicit none private ! Modules are private by default + character(len=*), parameter, private :: sourcefile = & + __FILE__ + integer, parameter, public :: maxlen_varname = 128 integer, parameter, public :: maxlen_varsymbol = 32 integer, parameter, public :: maxlen_varunits = 32 @@ -578,8 +581,7 @@ subroutine CheckInitialConditions(this) if(this%variables(i_var)%val(i_cor) < check_initialized) then i_organ = prt_global%state_descriptor(i_var)%organ_id - i_element = prt_global%state_descriptor(i_var)%element_id - + i_element = prt_global%state_descriptor(i_var)%element_id write(fates_log(),*)'Not all initial conditions for state variables' write(fates_log(),*)' in PRT hypothesis: ',trim(prt_global%hyp_name) write(fates_log(),*)' were written out.' @@ -588,7 +590,7 @@ subroutine CheckInitialConditions(this) write(fates_log(),*)' organ_id:',i_organ write(fates_log(),*)' element_id',i_element write(fates_log(),*)'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do @@ -946,7 +948,7 @@ subroutine CheckMassConservation(this,ipft,position_id) this%variables(i_var)%turnover(i_pos), & this%variables(i_var)%burned(i_pos) write(fates_log(),*) ' Exiting.' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do @@ -1204,7 +1206,7 @@ function GetCoordVal(this, organ_id, element_id ) result(prt_val) real(r8) :: prt_val write(fates_log(),*)'Init must be extended by a child class.' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end function GetCoordVal @@ -1215,7 +1217,7 @@ subroutine DailyPRTBase(this) class(prt_vartypes) :: this write(fates_log(),*)'Daily PRT Allocation must be extended' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end subroutine DailyPRTBase @@ -1226,7 +1228,7 @@ subroutine FastPRTBase(this) class(prt_vartypes) :: this write(fates_log(),*)'FastReactiveTransport must be extended by a child class.' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end subroutine FastPRTBase @@ -1253,7 +1255,7 @@ subroutine SetState(prt,organ_id, element_id, state_val, position_id) if(element_id == all_carbon_elements) then write(fates_log(),*) 'You cannot set the state of all isotopes simultaneously.' write(fates_log(),*) 'You can only set 1. Exiting.' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if( present(position_id) ) then @@ -1269,7 +1271,7 @@ subroutine SetState(prt,organ_id, element_id, state_val, position_id) write(fates_log(),*) 'greater than the allocated position space' write(fates_log(),*) ' i_pos: ',i_pos write(fates_log(),*) ' num_pos: ',prt_global%state_descriptor(i_var)%num_pos - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1282,7 +1284,7 @@ subroutine SetState(prt,organ_id, element_id, state_val, position_id) write(fates_log(),*) ' organ_id:',organ_id write(fates_log(),*) ' element_id:',element_id write(fates_log(),*) 'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if From 957c1c5d4ad116638efe4c4daa9e59c0f938ccab Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 7 Oct 2019 13:27:37 -0700 Subject: [PATCH 038/114] Re-adding the README in hydro unit functions --- functional_unit_testing/hydro/bld/README | 0 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 functional_unit_testing/hydro/bld/README diff --git a/functional_unit_testing/hydro/bld/README b/functional_unit_testing/hydro/bld/README new file mode 100644 index 0000000000..e69de29bb2 From 21fcbfacd1dfcde6c0685a61ae8542894602ccb9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 7 Oct 2019 13:40:00 -0700 Subject: [PATCH 039/114] Added functional unit test wrapper code for hydro. --- .../hydro/f90_src/EDParamsHydroMod.F90 | 61 +++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 diff --git a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 new file mode 100644 index 0000000000..3340c7bb0b --- /dev/null +++ b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 @@ -0,0 +1,61 @@ + +! THIS IS A STRIPPED DOWN VERSION OF main/EDParamsMod.F90 + + +module EDParamsMod + ! + ! module that deals with reading the ED parameter file + ! + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + use FatesConstantsMod, only : r8 => fates_r8 + + implicit none + private + save + + integer(kind=c_int), parameter :: param_string_length = 32 + + ! Hydraulics Control Parameters + ! ---------------------------------------------------------------------------------------------- + real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface + ! soil to root direction (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" + + real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface + ! root to soil direciton (kg water/m2 root area/Mpa/s) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" + + real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" + + real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) + character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" + + public :: EDParamsPySet + +contains + + subroutine EDParamsPySet(rval,name) + + implicit none + ! Arguments + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + + if(trim(name) == trim(hydr_name_psi0))then + hydr_psi0 = rval + elseif(trim(name) == trim(hydr_name_psicap))then + hydr_psicap = rval + else + print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) + stop + end if + + return + end subroutine EDParamsPySet + + + + +end module EDParamsMod From 3e5a08589a281442e18a54eb5e7aebcf1781ab00 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 7 Oct 2019 15:08:35 -0700 Subject: [PATCH 040/114] Enabling more compartment combos in new hydro unit tests. --- biogeophys/FatesHydroWTFMod.F90 | 56 +++++++++-------- .../hydro/HydroUTestDriver.py | 62 +++++++++++-------- .../hydro/f90_src/HydroUnitWrapMod.F90 | 36 ++++------- main/FatesConstantsMod.F90 | 1 - 4 files changed, 78 insertions(+), 77 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index db70f96695..28617c9349 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -53,6 +53,17 @@ module FatesHydroWTFMod procedure :: set_wkf_param => set_wkf_param_base end type wkf_type + ! The WRF and WKF types cannot be arrays themselves + ! we require these holders + + type, public :: wrf_arr_type + class(wrf_type), pointer :: p + end type wrf_arr_type + + type, public :: wkf_arr_type + class(wkf_type), pointer :: p + end type wkf_arr_type + ! ===================================================================================== ! Van Genuchten WTF Definitions @@ -60,7 +71,7 @@ module FatesHydroWTFMod ! Water Retention Function type, public, extends(wrf_type) :: wrf_type_vg - real(r8) :: alpha ! Inverse air entry parameter + real(r8) :: alpha ! Inverse air entry parameter [m3/Mpa] real(r8) :: psd ! Inverse width of pore size distribution parameter real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] @@ -73,7 +84,7 @@ module FatesHydroWTFMod ! Water Conductivity Function type, public, extends(wkf_type) :: wkf_type_vg - real(r8) :: alpha ! Inverse air entry parameter + real(r8) :: alpha ! Inverse air entry parameter [m3/Mpa] real(r8) :: psd ! Inverse width of pore size distribution parameter real(r8) :: tort ! Tortuosity parameter (sometimes "l") real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] @@ -218,9 +229,6 @@ subroutine set_wrf_param_vg(this,params_in) this%th_sat = params_in(3) this%th_res = params_in(4) - print*,this%alpha,this%psd,this%th_sat,this%th_res - - return end subroutine set_wrf_param_vg @@ -248,14 +256,15 @@ function th_from_psi_vg(this,psi) result(th) ! from matric potential. class(wrf_type_vg) :: this - real(r8), intent(in) :: psi - real(r8) :: satfrac - real(r8) :: th + real(r8), intent(in) :: psi ! Matric potential [MPa] + real(r8) :: satfrac ! Saturated fraction [-] + real(r8) :: th ! Volumetric Water Cont [m3/m3] !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m ! Saturation fraction + ! - satfrac = (1._r8 + (this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) + satfrac = (1._r8 + (-this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) ! convert to volumetric water content th = satfrac*(this%th_sat-this%th_res) + this%th_res @@ -283,11 +292,8 @@ function psi_from_th_vg(this,th) result(psi) satfrac = (th-this%th_res)/(this%th_sat-this%th_res) - print*,"sf: ",satfrac - stop - m = 1._r8/this%psd - psi = (1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m end function psi_from_th_vg @@ -309,12 +315,12 @@ function dpsidth_from_th_vg(this,th) result(dpsidth) satfrac = (th-this%th_res)/(this%th_sat-this%th_res) - ! psi = a1*(satfrac**m2 - 1._r8 )**m1 + ! psi = -a1*(satfrac**m2 - 1._r8 )**m1 ! f(x) = satfrac**m2 -1 ! g(x) = a1*f(x)**m1 ! dpsidth = g'(f(x)) f'(x) - dpsidth = (m2/(this%th_sat - this%th_res))*m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) + dpsidth = -(m2/(this%th_sat - this%th_res))*m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) end function dpsidth_from_th_vg @@ -328,9 +334,9 @@ function ftc_from_psi_vg(this,psi) result(ftc) real(r8) :: den ! denominator term real(r8) :: ftc - num = (1._r8 - (this%alpha*psi)**(this%psd-1._r8) * & - (1._r8 + (this%alpha*psi)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 - den = (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*(1._r8-1._r8/this%psd)) + num = (1._r8 - (-this%alpha*psi)**(this%psd-1._r8) * & + (1._r8 + (-this%alpha*psi)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 + den = (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*(1._r8-1._r8/this%psd)) ftc = num/den @@ -356,21 +362,21 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) real(r8) :: dden ! derivative of denominator real(r8) :: dftcdpsi ! change in frac total cond wrt psi - t1 = (this%alpha*psi)**(this%psd-1._r8) + t1 = (-this%alpha*psi)**(this%psd-1._r8) dt1 = this%alpha**(this%psd-1._r8)*(this%psd-1._r8)*psi**(this%psd-2._r8) - t2 = (1._r8 + (this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) + t2 = (1._r8 + (-this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) dt2 = -(1._r8-1._r8/this%psd) * & - (1._r8 + (this%alpha*psi)**this%psd)**(1._r8/this%psd) * & - this%psd*(this%alpha**this%psd)*psi**(this%psd-1._r8) + (1._r8 + (-this%alpha*psi)**this%psd)**(1._r8/this%psd) * & + this%psd*(this%alpha**this%psd)*(-psi)**(this%psd-1._r8) num = (1._r8 - t1*t2)**2._r8 dnum = 2._r8 * (1._r8 - t1*t2) * ( t1*dt2 + t2*dt1 ) - den = (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) + den = (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) dden = (this%tort*( 1._r8-1._r8/this%psd)) * & - (1._r8 + (this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)-1._r8) * & - this%alpha**this%psd * this%psd * psi**(this%psd-1._r8) + (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)-1._r8) * & + this%alpha**this%psd * this%psd * (-psi)**(this%psd-1._r8) dftcdpsi = dnum*den**(-1._r8) - (den**(-2._r8))*dden*num diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index ff3406533e..feff4b0d7f 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -40,23 +40,11 @@ f90_edparams_obj = ctypes.CDLL('bld/EDParamsHydroMod.o',mode=ctypes.RTLD_GLOBAL) f90_constants_obj = ctypes.CDLL('bld/FatesConstantsMod.o',mode=ctypes.RTLD_GLOBAL) f90_unitwrap_obj = ctypes.CDLL('bld/UnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) -#f90_hydrofuncs_obj = ctypes.CDLL('bld/FatesHydroUnitFunctionsMod.o',mode=ctypes.RTLD_GLOBAL) f90_wftfuncs_obj = ctypes.CDLL('bld/FatesHydroWTFMod.o',mode=ctypes.RTLD_GLOBAL) f90_hydrounitwrap_obj = ctypes.CDLL('bld/HydroUnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) # Alias the F90 functions, specify the return type # ----------------------------------------------------------------------------------- -#psi_from_th = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_psi_from_th -#psi_from_th.restype = c_double - -#dpsidth_from_th= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dpsidth_from_th -#dpsidth_from_th.restype = c_double - -#flc_from_psi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_flc_from_psi -#flc_from_psi.restype = c_double - -#dflcdpsi_from_psi= f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dflcdpsi_from_psi -#dflcdpsi_from_psi.restype = c_double initalloc_wtfs = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_initallocwtfs setwrf = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_setwrf @@ -72,10 +60,6 @@ dftcdpsi_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapftcfrompsi dftcdpsi_from_psi.restype = c_double -#solutepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_solutepsi -#pressurepsi = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_pressurepsi -#delasticPVdth = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_delasticpvdth -#dcavitationPVdth = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_dcavitationpvdth # Some constants rwcft = [1.0,0.958,0.958,0.958] @@ -222,32 +206,58 @@ def main(argv): #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(3),c8(rwcft[2]),c8(rwccap[2])) #iret = f90_hydrofuncs_obj.__fateshydrounitfunctionsmod_MOD_setplantmediaparam(ci(4),c8(rwcft[3]),c8(rwccap[3])) + # Set number of analysis points npts = 1000 - iret = initalloc_wtfs(ci(1),ci(1)) + # min_theta = np.full(shape=(2),dtype=np.float64,fill_value=np.nan) + + th_ress = [0.10, 0.20, 0.30, 0.40] + th_sats = [0.65, 0.65, 0.65, 0.65] + alphas = [1.0, 1.0, 1.0, 1.0] + psds = [2.7, 2.7, 2.7, 2.7] + + ncomp = len(th_sats) + + # Allocate memory to our objective classes + iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) print('Allocated') -# code.interact(local=dict(globals(), **locals())) - init_wrf_args = (4 * c_double)(0.001,2.7,0.65,0.35) # alpha, psd, th_sat, th_res + # Push parameters to those classes + # ------------------------------------------------------------------------- + # Generic VGs + init_wrf_args = (4 * c_double)(alphas[0],psds[0],th_sats[0],th_ress[0]) # alpha, psd, th_sat, th_res iret = setwrf(ci(1),ci(1),ci(4),byref(init_wrf_args)) + init_wrf_args = (4 * c_double)(alphas[1],psds[1],th_sats[1],th_ress[1]) # alpha, psd, th_sat, th_res + iret = setwrf(ci(2),ci(1),ci(4),byref(init_wrf_args)) + + init_wrf_args = (4 * c_double)(alphas[2],psds[2],th_sats[2],th_ress[2]) # alpha, psd, th_sat, th_res + iret = setwrf(ci(3),ci(1),ci(4),byref(init_wrf_args)) + + init_wrf_args = (4 * c_double)(alphas[3],psds[3],th_sats[3],th_ress[3]) # alpha, psd, th_sat, th_res + iret = setwrf(ci(4),ci(1),ci(4),byref(init_wrf_args)) + print('initialized WRF') - init_wkf_args = (5 * c_double)(0.001,2.7,0.65,0.35,0.5) - iret = setwkf(ci(1),ci(1),ci(5),byref(init_wkf_args)) - stem_theta = np.linspace(0.35, 0.65, num=npts) - stem_psi = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - for i,th in enumerate(stem_theta): - stem_psi[i] = psi_from_th(ci(1),c8(th)) + stem_theta = np.linspace(0.10, 0.7, num=npts) + stem_psi = np.full(shape=(ncomp,len(stem_theta)),dtype=np.float64,fill_value=np.nan) + + + for ic in range(ncomp): + + for i,th in enumerate(stem_theta): + stem_psi[ic,i] = psi_from_th(ci(ic+1),c8(th)) fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) - ax1.plot(stem_theta,stem_psi,label='stem vg') + for ic in range(ncomp): + ax1.plot(stem_theta,stem_psi[ic,:]) + ax1.set_ylim((-10,0)) plt.show() diff --git a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 index 5ef1c410c2..16d06f8661 100644 --- a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -13,7 +13,7 @@ module HydroUnitWrapMod use FatesHydroWTFMod, only : wrf_type,wrf_type_vg,wrf_type_cch use FatesHydroWTFMod, only : wkf_type,wkf_type_vg,wkf_type_cch,wkf_type_tfs - + use FatesHydroWTFMod, only : wrf_arr_type,wkf_arr_type implicit none public @@ -26,23 +26,9 @@ module HydroUnitWrapMod integer, public, parameter :: tfs = 3 - type wrf_arr_type - class(wrf_type), pointer :: wrf_obj - end type wrf_arr_type - - type wkf_arr_type - class(wkf_type), pointer :: wkf_obj - end type wkf_arr_type - - -! IMPLEMENT THE ARR TYPE RYAN - class(wrf_arr_type), public, pointer :: wrfs(:) ! This holds all (soil and plant) water retention functions class(wkf_arr_type), public, pointer :: wkfs(:) ! -! class(wrf_type), public, pointer :: wrfs(:) -! class(wkf_type), public, pointer :: wkfs(:) - contains @@ -77,11 +63,11 @@ subroutine SetWRF(index,itype,npvals,pvals) if(itype == van_genuchten) then allocate(wrf_vg) - wrfs(index)%wrf_obj => wrf_vg + wrfs(index)%p => wrf_vg call wrf_vg%set_wrf_param(pvals) !alpha,psd,th_sat,th_res elseif(itype==campbell) then allocate(wrf_cch) - wrfs(index)%wrf_obj => wrf_cch + wrfs(index)%p => wrf_cch call wrf_cch%set_wrf_param(pvals) !th_sat,psi_sat,beta else print*,"UNKNOWN WRF" @@ -104,15 +90,15 @@ subroutine SetWKF(index,itype,npvals,pvals) if(itype == van_genuchten) then allocate(wkf_vg) - wkfs(index)%wkf_obj => wkf_vg + wkfs(index)%p => wkf_vg call wkf_vg%set_wkf_param(pvals) !alpha,psd,th_sat,th_res,tort elseif(itype==campbell) then allocate(wkf_cch) - wkfs(index)%wkf_obj => wkf_cch + wkfs(index)%p => wkf_cch call wkf_cch%set_wkf_param(pvals) !th_sat,psi_sat,beta elseif(itype==tfs) then allocate(wkf_tfs) - wkfs(index)%wkf_obj => wkf_tfs + wkfs(index)%p => wkf_tfs call wkf_tfs%set_wkf_param(pvals) !th_sat,p50,avuln else print*,"UNKNOWN WKF" @@ -129,7 +115,7 @@ function WrapTHFromPSI(index,psi) result(th) real(r8),intent(in) :: psi real(r8) :: th - th = wrfs(index)%wrf_obj%th_from_psi(psi) + th = wrfs(index)%p%th_from_psi(psi) return end function WrapTHFromPSI @@ -141,7 +127,7 @@ function WrapPSIFromTH(index,th) result(psi) real(r8),intent(in) :: th real(r8) :: psi - psi = wrfs(index)%wrf_obj%psi_from_th(th) + psi = wrfs(index)%p%psi_from_th(th) end function WrapPSIFromTH @@ -152,7 +138,7 @@ function WrapDPSIDTH(index,th) result(dpsidth) real(r8),intent(in) :: th real(r8) :: dpsidth - dpsidth = wrfs(index)%wrf_obj%dpsidth_from_th(th) + dpsidth = wrfs(index)%p%dpsidth_from_th(th) end function WrapDPSIDTH @@ -163,7 +149,7 @@ function WrapDFTCDPSI(index,psi) result(dftcdpsi) real(r8),intent(in) :: psi real(r8) :: dftcdpsi - dftcdpsi = wkfs(index)%wkf_obj%dftcdpsi_from_psi(psi) + dftcdpsi = wkfs(index)%p%dftcdpsi_from_psi(psi) end function WrapDFTCDPSI @@ -174,7 +160,7 @@ function WrapFTCFromPSI(index,psi) result(ftc) real(r8),intent(in) :: psi real(r8) :: ftc - ftc = wkfs(index)%wkf_obj%ftc_from_psi(psi) + ftc = wkfs(index)%p%ftc_from_psi(psi) return end function WrapFTCFromPSI diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index a13ef7ef24..c95f0882dc 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -154,7 +154,6 @@ module FatesConstantsMod ! Pascals to megapascals real(fates_r8), parameter, public :: mpa_per_pa = 1.e-6_fates_r8 - ! For numerical inquiry real(fates_r8), parameter, public :: fates_huge = huge(g_per_kg) From 1901ab987ad61f91c470d56e506fc89c92c11bd4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 8 Oct 2019 10:37:25 -0700 Subject: [PATCH 041/114] Fixed vg hydro wtfs. --- biogeophys/FatesHydroWTFMod.F90 | 60 +++++++++++++++---- .../hydro/HydroUTestDriver.py | 57 ++++++++++-------- 2 files changed, 81 insertions(+), 36 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 28617c9349..6030e308a0 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -30,6 +30,8 @@ module FatesHydroWTFMod real(r8), parameter :: min_ftc = 0.005_r8 + real(r8), parameter :: min_rwc_interp = 0.02 + real(r8), parameter :: max_rwc_interp = 0.98 ! Generic class that can be extended to describe ! specific water retention functions @@ -75,6 +77,7 @@ module FatesHydroWTFMod real(r8) :: psd ! Inverse width of pore size distribution parameter real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] + contains procedure :: th_from_psi => th_from_psi_vg procedure :: psi_from_th => psi_from_th_vg @@ -283,17 +286,43 @@ function psi_from_th_vg(this,th) result(psi) real(r8) :: psi real(r8) :: m ! inverse of psd real(r8) :: satfrac ! saturated fraction + real(r8) :: th_interp ! theta where we start interpolation + real(r8) :: psi_inter ! psi at interpolation point !------------------------------------------------------------------------------------ ! saturation fraction is the origial equation in vg 1980, we just ! need to invert it: ! satfrac = (1._r8 + (alpha*psi)**n)**(1._r8/n-1) + ! we also modify these functions to ! ----------------------------------------------------------------------------------- - - satfrac = (th-this%th_res)/(this%th_sat-this%th_res) m = 1._r8/this%psd - psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + + if(satfrac>max_rwc_interp) then + + th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res + dpsidth_interp = this%dpsidth_from_th(th_interp) + psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m + psi = psi_interp + dspidth_interp*(th-th_interp) + + elseif(satfrac Date: Tue, 8 Oct 2019 12:11:15 -0700 Subject: [PATCH 042/114] Updating hydro unit tests. --- biogeophys/FatesHydroWTFMod.F90 | 17 ++++---- .../hydro/HydroUTestDriver.py | 40 ++++++++++++------- .../shared/py_src/PyF90Utils.py | 8 ++++ 3 files changed, 42 insertions(+), 23 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 6030e308a0..b6754dce08 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -283,12 +283,13 @@ function psi_from_th_vg(this,th) result(psi) class(wrf_type_vg) :: this real(r8),intent(in) :: th - real(r8) :: psi - real(r8) :: m ! inverse of psd - real(r8) :: satfrac ! saturated fraction - real(r8) :: th_interp ! theta where we start interpolation - real(r8) :: psi_inter ! psi at interpolation point - + real(r8) :: psi ! matric potential [MPa] + real(r8) :: m ! inverse of psd + real(r8) :: satfrac ! saturated fraction + real(r8) :: th_interp ! theta where we start interpolation + real(r8) :: psi_interp ! psi at interpolation point + real(r8) :: dpsidth_interp + !------------------------------------------------------------------------------------ ! saturation fraction is the origial equation in vg 1980, we just ! need to invert it: @@ -304,14 +305,14 @@ function psi_from_th_vg(this,th) result(psi) th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res dpsidth_interp = this%dpsidth_from_th(th_interp) psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m - psi = psi_interp + dspidth_interp*(th-th_interp) + psi = psi_interp + dpsidth_interp*(th-th_interp) elseif(satfrac Date: Thu, 31 Oct 2019 15:37:55 -0700 Subject: [PATCH 043/114] Debugging hydros new wtf functions --- ...F90 => FatesHydroUnitFunctionsMod.F90_old} | 294 +--- biogeophys/FatesHydroWTFMod.F90 | 105 +- biogeophys/FatesPlantHydraulicsMod.F90 | 1446 ++++++++++------- .../hydro/HydroUTestDriver.py | 104 +- .../shared/py_src/PyF90Utils.py | 10 +- main/EDInitMod.F90 | 92 ++ main/FatesHydraulicsMemMod.F90 | 50 +- main/FatesInterfaceMod.F90 | 97 +- 8 files changed, 1122 insertions(+), 1076 deletions(-) rename biogeophys/{FatesHydroUnitFunctionsMod.F90 => FatesHydroUnitFunctionsMod.F90_old} (86%) diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90 b/biogeophys/FatesHydroUnitFunctionsMod.F90_old similarity index 86% rename from biogeophys/FatesHydroUnitFunctionsMod.F90 rename to biogeophys/FatesHydroUnitFunctionsMod.F90_old index 96c564b84a..1a19b9eb6a 100644 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90 +++ b/biogeophys/FatesHydroUnitFunctionsMod.F90_old @@ -98,6 +98,7 @@ module FatesHydroUnitFunctionsMod public :: th_from_psi public :: psi_from_th public :: dpsidth_from_th + public :: bisect_rootfr public :: zeng2001_crootfr public :: shellGeom @@ -184,85 +185,7 @@ subroutine SetPlantMediaParam(pm,rwcft_in,rwccap_in) return end subroutine SetPlantMediaParam - ! ===================================================================================== - subroutine Hydraulics_Tridiagonal(a, b, c, r, u) - ! - ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 - ! - ! This solves the form: - ! - ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) - ! - ! It assumed that coefficient a(1) and c(N) DNE as there is - ! no u(0) or u(N-1). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix - real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix - real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix - real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix - real(r8), intent(out) :: u(:) ! solution - ! - ! !LOCAL VARIABLES: - real(r8) :: bet ! temporary - real(r8) :: gam(10) ! temporary - integer :: k ! index - integer :: N ! Size of the matrix - real(r8) :: err ! solution error, in units of [m3/m3] - real(r8) :: rel_err ! relative error, normalized by delta theta - real(r8), parameter :: allowable_rel_err = 0.0001_r8 - - ! real(r8), parameter :: allowable_err = 1.e-6_r8 - !---------------------------------------------------------------------- - N=size(r,dim=1) - bet = b(1) - do k=1,N - if(k == 1) then - u(k) = r(k) / bet - else - gam(k) = c(k-1) / bet - bet = b(k) - a(k) * gam(k) - u(k) = (r(k) - a(k)*u(k-1)) / bet - end if - enddo - - do k=N-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) - enddo - - ! If debug mode, calculate error on the forward solution - if(debug)then - do k=1,N - - if(k==1)then - err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) - elseif(knearzero)then - rel_err = abs(err/u(k)) - - if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then - write(fates_log(),*) 'Tri-diagonal solve produced solution with' - write(fates_log(),*) 'non-negligable error.' - write(fates_log(),*) 'Compartment: ',k - write(fates_log(),*) 'Error in forward solution: ',err - write(fates_log(),*) 'Estimated delta theta: ',u(k) - write(fates_log(),*) 'Rel Error: ',rel_err - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do - end if - - end subroutine Hydraulics_Tridiagonal !===============================================================================! @@ -2003,222 +1926,7 @@ subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) end subroutine unsatkCampbell_dflcdpsi_from_psi - ! ===================================================================================== - ! Utility Functions - ! ===================================================================================== - - subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants - real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] - real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] - real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] - real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] - real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] - real(r8) , intent(out) :: x_new ! soil depth [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound x estimate [m] - real(r8) :: upper ! upper bound x estimate [m] - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - !---------------------------------------------------------------------- - - lower = lower_init - upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr - chg = upper - lower - do while(abs(chg) .gt. xtol) - x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - end do - end subroutine bisect_rootfr - - ! ===================================================================================== - - function zeng2001_crootfr(a, b, z, z_max) result(crootfr) - - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - real(r8) , intent(in), optional :: z_max ! max soil depth (m) - ! - real(r8) :: crootfr_max - - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) - - - ! If a maximum rooting depth is provided, then - ! we force everything to sum to unity. We do this by - ! simply dividing through by the maximum possible - ! root fraction. - - if(present(z_max))then - crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) - crootfr = crootfr/crootfr_max - end if - - if(debug)then - if(present(z_max))then - if((crootfr_max1.0_r8) )then - write(fates_log(),*) 'problem scaling crootfr in zeng2001' - write(fates_log(),*) 'z_max: ',z_max - write(fates_log(),*) 'crootfr_max: ',crootfr_max - end if - end if - end if - - - return - - end function zeng2001_crootfr - - ! ===================================================================================== - - subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: - - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots - ! for the whole site, this layer (m) - real(r8) , intent(in) :: rs1 ! Fine root radius (m) - real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) - real(r8) , intent(in) :: dz ! Width of current soil layer (m) - real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) - real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint - real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) - ! for this layer - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - integer :: nshells ! We don't use the global because of unit testing - !----------------------------------------------------------------------- - - nshells = size(r_out_shell,dim=1) - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - if(voltype==bcvol)then - do k = 1,nshells - if(k == 1) then - ! BOC...not doing this as it requires PFT-specific fine root thickness but this is at column level - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - rs1**2._r8) - - else - v_shell(k) = pi_const*dz*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo - elseif(voltype==rkvol)then - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo - end if - - end subroutine shellGeom - - ! ===================================================================================== - - function xylemtaper(p, dz) result(chi_tapnotap) - - ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] - real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) - real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) - ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) - ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. - ! Hydraulic trade-offs and space filling enable better predictions of vascular structure - ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. - real(r8) :: lN=0.04_r8 ! petiole length [m] - real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] - real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] - real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: num ! temporary - real(r8) :: den ! temporary - ! - ! !RESULT - real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz - ! - !------------------------------------------------------------------------ - - anotap = 7.19903e-13_r8 - bnotap = 1.326105578_r8 - if (p >= 1.0_r8) then - btap = 2.00586217_r8 - atap = 1.82513E-12_r8 - else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then - btap = 1.854812819_r8 - atap = 6.66908E-13_r8 - else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then - btap = 1.628179741_r8 - atap = 6.58345E-13_r8 - else - btap = bnotap - atap = anotap - end if - - num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) - den = log(little_n) - big_n = num/den - 1._r8 - ktap = atap * (little_n**(big_N* btap/2._r8)) - knotap = anotap * (little_n**(big_N*bnotap/2._r8)) - chi_tapnotap = ktap / knotap - - return - end function xylemtaper end module FatesHydroUnitFunctionsMod diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index b6754dce08..512162f2ca 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -372,13 +372,25 @@ function ftc_from_psi_vg(this,psi) result(ftc) real(r8) :: num ! numerator term real(r8) :: den ! denominator term real(r8) :: ftc + real(r8) :: psi_eff - num = (1._r8 - (-this%alpha*psi)**(this%psd-1._r8) * & - (1._r8 + (-this%alpha*psi)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 - den = (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*(1._r8-1._r8/this%psd)) + if(psi<0._r8) then - ftc = num/den + ! VG 1980 assumes a postive pressure convention... + psi_eff = -psi + + num = (1._r8 - (this%alpha*psi_eff)**(this%psd-1._r8) * & + (1._r8 + (this%alpha*psi_eff)**this%psd)**(-(1._r8-1._r8/this%psd)))**2._r8 + den = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*(1._r8-1._r8/this%psd)) + + ! Make sure this is well behaved + ftc = min(1._r8,max(min_ftc,num/den)) + else + ftc = 1._r8 + + end if + end function ftc_from_psi_vg ! ==================================================================================== @@ -387,38 +399,49 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) ! The derivative of the fraction of total conductivity ! Note, this function is fairly complex. To get the derivative - ! we brake it into terms, and also into numerator and denominator - ! and then differentiate those by parts + ! we brake it into terms, see the technical note. + class(wkf_type_vg) :: this real(r8),intent(in) :: psi + real(r8) :: psi_eff ! VG 1980 assumed positive convention, so we switch sign real(r8) :: t1 ! term 1 in numerator real(r8) :: t2 ! term 2 in numerator + real(r8) :: t3 ! term 3 (denomenator) real(r8) :: dt1 ! derivative of term 1 real(r8) :: dt2 ! derivative of term 2 - real(r8) :: num ! numerator - real(r8) :: dnum ! derivative of numerator - real(r8) :: den ! denominator - real(r8) :: dden ! derivative of denominator + real(r8) :: dt3 ! derivative of term 3 + real(r8) :: ftc ! calculate current ftc to see if we are at min real(r8) :: dftcdpsi ! change in frac total cond wrt psi - - t1 = (-this%alpha*psi)**(this%psd-1._r8) - dt1 = this%alpha**(this%psd-1._r8)*(this%psd-1._r8)*psi**(this%psd-2._r8) - t2 = (1._r8 + (-this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) - dt2 = -(1._r8-1._r8/this%psd) * & - (1._r8 + (-this%alpha*psi)**this%psd)**(1._r8/this%psd) * & - this%psd*(this%alpha**this%psd)*(-psi)**(this%psd-1._r8) - - num = (1._r8 - t1*t2)**2._r8 - dnum = 2._r8 * (1._r8 - t1*t2) * ( t1*dt2 + t2*dt1 ) + if(psi>=0._r8) then + dftcdpsi = 0._r8 + else + psi_eff = -psi ! switch VG 1980 convention + + ftc = this%ftc_from_psi(psi) - den = (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) - dden = (this%tort*( 1._r8-1._r8/this%psd)) * & - (1._r8 + (-this%alpha*psi)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)-1._r8) * & - this%alpha**this%psd * this%psd * (-psi)**(this%psd-1._r8) + if(ftc<=min_ftc) then + dftcdpsi = 0._r8 ! We cap ftc, so derivative is zero + else + t1 = (this%alpha*psi_eff)**(this%psd-1._r8) + dt1 = this%alpha*(this%psd-1._r8)*(this%alpha*psi_eff)**(this%psd-2._r8) + + t2 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(1._r8/this%psd-1._r8) + dt2 = (1._r8/this%psd-1._r8) * & + (1._r8 + (this%alpha*psi_eff)**this%psd)**(1._r8/this%psd-2._r8) * & + this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha + + t3 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) + dt3 = this%tort*(1._r8-1._r8/this%psd) * & + (1._r8 + (this%alpha*psi_eff)**this%psd )**(this%tort*(1._r8-1._r8/this%psd)-1._r8) * & + this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha + + dftcdpsi = 2._r8*(1._r8-t1*t2)*(t1*dt2 + t2*dt1)/t3 - & + t3**(-2._r8)*dt3*(1._r8-t1*t2)**2._r8 + end if - dftcdpsi = dnum*den**(-1._r8) - (den**(-2._r8))*dden*num + end if end function dftcdpsi_from_psi_vg @@ -427,7 +450,7 @@ end function dftcdpsi_from_psi_vg ! Campbell, Clapp-Hornberger Water Retention Functions ! ===================================================================================== ! ===================================================================================== - + subroutine set_wrf_param_cch(this,params_in) class(wrf_type_cch) :: this @@ -459,7 +482,7 @@ end subroutine set_wkf_param_cch function th_from_psi_cch(this,psi) result(th) - class(wrf_type_cch) :: this + class(wrf_type_cch) :: this real(r8), intent(in) :: psi real(r8) :: th real(r8) :: satfrac @@ -474,7 +497,7 @@ end function th_from_psi_cch function psi_from_th_cch(this,th) result(psi) - class(wrf_type_cch) :: this + class(wrf_type_cch) :: this real(r8),intent(in) :: th real(r8) :: psi @@ -506,7 +529,7 @@ function ftc_from_psi_cch(this,psi) result(ftc) real(r8),intent(in) :: psi real(r8) :: psi_eff real(r8) :: ftc - + ! th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) ! ftc = ((psi/this%psi_sat)**(-1.0_r8/this%beta))**(2._r8*this%beta+3._r8) ! @@ -551,9 +574,8 @@ subroutine set_wkf_param_tfs(this,params_in) class(wkf_type_tfs) :: this real(r8), intent(in) :: params_in(:) - this%th_sat = params_in(1) - this%p50 = params_in(2) - this%avuln = params_in(3) + this%p50 = params_in(1) + this%avuln = params_in(2) return end subroutine set_wkf_param_tfs @@ -565,8 +587,11 @@ function ftc_from_psi_tfs(this,psi) result(ftc) class(wkf_type_tfs) :: this real(r8),intent(in) :: psi ! real(r8) :: ftc + real(r8) :: psi_eff + + psi_eff = min(0._r8,psi) - ftc = max(min_ftc,1._r8/(1._r8 + (psi/this%p50)**this%avuln)) + ftc = max(min_ftc,1._r8/(1._r8 + (psi_eff/this%p50)**this%avuln)) end function ftc_from_psi_tfs @@ -584,13 +609,17 @@ function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) ! Differentiate ! ftc = 1._r8/(1._r8 + (psi/this%p50(ft))**this%avuln(ft)) - ftc = 1._r8/(1._r8 + (psi/this%p50)**this%avuln) - if(ftc0._r8)then dftcdpsi = 0._r8 else - fx = 1._r8 + (psi/this%p50)**this%avuln - dfx = this%avuln*(psi/this%p50)**(this%avuln-1._r8) - dftcdpsi = -fx**(-2._r8)*dfx + ftc = 1._r8/(1._r8 + (psi/this%p50)**this%avuln) + if(ftc shr_log_errMsg @@ -157,14 +142,7 @@ module FatesPlantHydraulicsMod ! proceeds over the entire time-step. - integer, public, parameter :: van_genuchten = 1 - integer, public, parameter :: campbell = 2 - integer, public, parameter :: tfs = 3 - integer, parameter :: plant_wrf_type = van_genuchten - integer, parameter :: plant_wkf_type = tfs - integer, parameter :: soil_wrf_type = campbell - integer, parameter :: soil_wkf_type = campbell @@ -177,20 +155,36 @@ module FatesPlantHydraulicsMod ! We use this parameter as the value for which we set un-initialized values real(r8), parameter :: un_initialized = -9.9e32_r8 - + + integer, public, parameter :: van_genuchten_type = 1 + integer, public, parameter :: campbell_type = 2 + integer, public, parameter :: tfs_type = 3 + + integer, parameter :: plant_wrf_type = van_genuchten_type + integer, parameter :: plant_wkf_type = tfs_type + integer, parameter :: soil_wrf_type = campbell_type + integer, parameter :: soil_wkf_type = campbell_type + + ! Define the global object that holds the water retention functions ! for plants of each different porous media type, and plant functional type - - class(wrf_type),pointer :: wrf_plant(:,:) + + class(wrf_arr_type),pointer :: wrf_plant(:,:) ! Define the global object that holds the water conductance functions ! for plants of each different porous media type, and plant functional type - - class(wkf_type), pointer :: wkf_plant(:,:) - + + class(wkf_arr_type), pointer :: wkf_plant(:,:) + + + ! This is a list of the porous media types for all of the compartments + ! going in 1D from top down order (leaf, stem, troot, aroot, rhiz shell) + integer, allocatable :: p_media_nodes(:) + + real(r8), parameter :: alpha_vg = 0.001_r8 real(r8), parameter :: th_sat_vg = 0.65_r8 - real(r8), parameter :: th_res_vg = 0.35_r8 + real(r8), parameter :: th_res_vg = 0.15_r8 real(r8), parameter :: psd_vg = 2.7_r8 real(r8), parameter :: tort_vg = 0.5_r8 @@ -221,6 +215,7 @@ module FatesPlantHydraulicsMod public :: UpdateTreeHydrLenVol public :: UpdatePlantKmax public :: ConstrainRecruitNumber + public :: InitHydroGlobals !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen @@ -229,94 +224,7 @@ module FatesPlantHydraulicsMod contains - subroutine InitHYDROGlobals() - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch - class(wrf_type_tfs), pointer :: wrf_tfs - class(wkf_type_tfs), pointer :: wkf_tfs - - - if(.not.use_ed_planthydraulics) return - - allocate(wrf_plant(n_p_media,numpft)) - allocate(wkf_plant(n_p_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wrf_type) - case(van_genuchten) - do ft = 1,numpft - do pm = 1, n_p_media - allocate(wrf_vg) - wrf_plant(pm,ft) => wrf_vg - wrf_vg%set_wrf_param_vg(alpha_in = alpha_vg, & - psd_in = psd_vg, & - th_sat_in = th_sat_vg, & - th_res_in = th_res_vg) - end do - end do - case(campbell) - write(fates_log(),*) 'campbell/clapp-hornberger retention curves not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs) - write(fates_log(),*) 'TFS water retention curves not yet added to plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wkf_type) - case(van_genuchten) - do ft = 1,numpft - do pm = 1, n_p_media - allocate(wkf_vg) - wkf_plant(pm,ft) => wkf_vg - wkf_vg%set_wkf_param_vg(alpha_in = alpha_vg, & - psd_in = psd_vg, & - th_sat_in = th_sat_vg, & - th_res_in = th_res_vg, & - tort_in = tort_vg) - end do - end do - case(campbell) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs) - do ft = 1,numpft - do pm = 1, n_p_media - allocate(wkf_tfs) - wkf_plant(pm,ft) => wkf_tfs - wkf_tfs%set_wkf_param_tfs(th_sat_in = EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - p50_in = EDPftvarcon_inst%hydr_p50_node(ft,pm), & - avuln_in = EDPftvarcon_inst%hydr_avuln_node(ft,pm)) - end do - end do - end select - - - - return - end subroutine InitHYDROGlobals @@ -381,6 +289,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) type(ed_cohort_type),pointer :: ccohort ! current cohort type(ed_cohort_hydr_type),pointer :: ccohort_hydr integer :: s ! site loop counter + integer :: j + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch do s = 1,nsites @@ -416,6 +329,61 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) sites(s)%si_hydr%r_node_shell_init(:,:) = un_initialized sites(s)%si_hydr%v_shell_init(:,:) = un_initialized + ! -------------------------------------------------------------------------------- + ! Initialize water transfer functions + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for soil! + ! -------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wrf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_vg) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_cch + call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS water retention curves not available for soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wkf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_vg) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_cch + call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS conductance not used in soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + + ! Update static quantities related to the rhizosphere call UpdateSizeDepRhizVolLenCon(sites(s), bc_in(s)) @@ -439,7 +407,6 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ! REQUIRED INPUTS: ! - ! csite%si_hydr%psisoi_liq_innershell(:) ! ccohort_hydr%z_node_troot(:) ! ccohort_hydr%z_node_aroot ! ccohort_hydr%z_node_ag @@ -475,13 +442,11 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ! watsat(c,j), watres(c,j), alpha_VG(c,j), n_VG(c,j), m_VG(c,j), l_VG(c,j), & ! smp) !ccohort_hydr%psi_aroot(j) = smp - !ccohort_hydr%psi_aroot(j) = csite%si_hydr%psisoi_liq_innershell(j) ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equilibrium between soil and root - ccohort_hydr%th_aroot(j) = th_from_psi(ft, aroot_p_media, ccohort_hydr%psi_aroot(j)) - ccohort_hydr%ftc_aroot(j) = flc_from_psi(ft, aroot_p_media, & - ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j)) + ccohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_aroot(j)) + + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do @@ -500,29 +465,27 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - mpa_per_pa*denh2o*grav_earth*dz if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 - ccohort_hydr%th_troot = th_from_psi(ft, troot_p_media, ccohort_hydr%psi_troot ) - ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & - ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot) + + ccohort_hydr%th_troot = wrf_plant(troot_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_troot) + + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + !working our way up a tree, assigning water potentials that are in !hydrostatic equilibrium with the water potential immediately below dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - mpa_per_pa*denh2o*grav_earth*dz if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 - ccohort_hydr%th_ag(n_hypool_ag) = th_from_psi(ft, stem_p_media, ccohort_hydr%psi_ag(n_hypool_ag)) - ccohort_hydr%ftc_ag(n_hypool_ag) = flc_from_psi(ft, stem_p_media, & - ccohort_hydr%th_ag(n_hypool_ag), & - ccohort_hydr%psi_ag(n_hypool_ag)) + + ccohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_ag(n_hypool_ag)) + ccohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(n_hypool_ag)) do k=n_hypool_ag-1, 1, -1 dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - mpa_per_pa*denh2o*grav_earth*dz if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 - ccohort_hydr%th_ag(k) = th_from_psi(ft, porous_media(k), ccohort_hydr%psi_ag(k)) - ccohort_hydr%ftc_ag(k) = flc_from_psi(ft, porous_media(k), & - ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k)) + ccohort_hydr%th_ag(k) = wrf_plant(stem_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do ccohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 @@ -534,7 +497,10 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) !initialize cohort-level btran - ccohort_hydr%btran = flc_gs_from_psi(ccohort_hydr%psi_ag(1),ccohort%pft) + ccohort_hydr%btran = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + + + !flc_gs_from_psi(ccohort_hydr%psi_ag(1),ccohort%pft) end subroutine initTreeHydStates @@ -555,32 +521,32 @@ subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) integer :: k ! loop index for compartments integer :: j ! Loop index for soil layers type(ed_cohort_hydr_type), pointer :: ccohort_hydr - + + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft ! Update Psi and FTC in above-ground compartments ! ----------------------------------------------------------------------------------- - do k = 1,n_hypool_ag - ccohort_hydr%psi_ag(k) = psi_from_th(ft, porous_media(k), ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = flc_from_psi(ft, porous_media(k), & - ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k)) + do k = 1,n_hypool_leaf + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do + + do k = n_hypool_leaf+1, n_hypool_ag + ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do ! Update the Psi and FTC for the transporting root compartment - ccohort_hydr%psi_troot = psi_from_th(ft, troot_p_media, ccohort_hydr%th_troot ) - ccohort_hydr%ftc_troot = flc_from_psi(ft, troot_p_media, & - ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot ) + ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) ! Update the Psi and FTC for the absorbing roots do j = 1, csite_hydr%nlevsoi_hyd - ccohort_hydr%psi_aroot(j) = psi_from_th(ft, aroot_p_media, ccohort_hydr%th_aroot(j)) - ccohort_hydr%ftc_aroot(j) = flc_from_psi(ft, aroot_p_media, & - ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j)) + ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do return @@ -822,7 +788,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) b_tot_carb = sapw_c + struct_c + leaf_c + fnrt_c b_canopy_carb = leaf_c b_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_tot_carb - b_canopy_biom = b_canopy_carb * C2B + b_canopy_biom = b_canopy_carb * EDPftvarcon_inst%c2b(ft) ! NOTE: SLATOP currently does not use any vertical scaling functions ! but that may not be so forever. ie sla = slatop (RGK-082017) @@ -830,14 +796,14 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/C2B + 781.899_r8 + denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 v_canopy = b_canopy_biom / denleaf ccohort_hydr%v_ag(1:n_hypool_leaf) = v_canopy / real(n_hypool_leaf,r8) b_stem_carb = b_tot_carb - b_bg_carb - b_canopy_carb - b_stem_biom = b_stem_carb * C2B ! kg DM + b_stem_biom = b_stem_carb * EDPftvarcon_inst%c2b(ft) !BOC...may be needed for testing/comparison w/ v_sapwood ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 @@ -866,7 +832,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - v_troot = b_woody_bg_carb * C2B / & + v_troot = b_woody_bg_carb * EDPftvarcon_inst%c2b(ft) / & (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) @@ -874,7 +840,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*g_per_kg*C2B*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) ! Estimate absorbing root volume (all layers) @@ -883,7 +849,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) l_aroot_tot ! Calculate Root Tissue density: - ! print*,'root tissue density: ',C2B*mg_per_kg*m3_per_mm3*fnrt_c / v_aroot_tot + ! print*,'root tissue density: ',EDPftvarcon_inst%c2b(ft)*mg_per_kg*m3_per_mm3*fnrt_c / v_aroot_tot v_root = v_aroot_tot + v_troot @@ -1019,8 +985,8 @@ function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) real(r8) :: th_corr ! corrected water content ! !------------------------------------------------------------------------ - ths = EDPftvarcon_inst%hydr_thetas_node(ft,porous_media(k)) - thr = ths * EDPftvarcon_inst%hydr_resid_node(ft,porous_media(k)) + ths = EDPftvarcon_inst%hydr_thetas_node(ft,p_media_nodes(k)) + thr = ths * EDPftvarcon_inst%hydr_resid_node(ft,p_media_nodes(k)) th_corr = max((thr+delta),min((ths-delta),th_uncorr)) return @@ -1120,6 +1086,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type integer :: j,k ! indices + integer :: ft site_hydr => currentSite%si_hydr @@ -1132,7 +1099,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne nextCohort%n*ncohort_hydr%th_troot)/newn ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & nextCohort%n*ncohort_hydr%th_aroot(:))/newn - ccohort_hydr%supsub_flag = 0._r8 + ccohort_hydr%supsub_flag = 0 ! Only save the iteration counters for the worse of the two cohorts if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then @@ -1141,29 +1108,27 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%iterlayer = ncohort_hydr%iterlayer end if - do k=1,n_hypool_ag - ccohort_hydr%psi_ag(k) = psi_from_th(currentCohort%pft, porous_media(k), & - ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = flc_from_psi(currentCohort%pft, porous_media(k), & - ccohort_hydr%th_ag(k), & - ccohort_hydr%psi_ag(k)) + ft = currentCohort%pft + do k=1,n_hypool_leaf + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do - ccohort_hydr%psi_troot = psi_from_th(currentCohort%pft, troot_p_media, & - ccohort_hydr%th_troot) - ccohort_hydr%ftc_troot = flc_from_psi(currentCohort%pft, troot_p_media, & - ccohort_hydr%th_troot, & - ccohort_hydr%psi_troot) + do k = n_hypool_leaf+1,n_hypool_ag + ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do + + ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) do j=1,site_hydr%nlevsoi_hyd - ccohort_hydr%psi_aroot(j) = psi_from_th(currentCohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j)) - ccohort_hydr%ftc_aroot(j) = flc_from_psi(currentCohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j), & - ccohort_hydr%psi_aroot(j)) + ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do - ccohort_hydr%btran = flc_gs_from_psi(ccohort_hydr%psi_ag(1),currentcohort%pft) + + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & nextCohort%n*ncohort_hydr%sapflow)/newn @@ -1239,28 +1204,14 @@ subroutine InitHydrSites(sites,bc_in,numpft) ! Locals integer :: nsites integer :: s + integer :: j type(ed_site_hydr_type),pointer :: csite_hydr - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch - class(wrf_type_tfs), pointer :: wrf_tfs - class(wkf_type_tfs), pointer :: wkf_tfs - if ( hlm_use_planthydro.eq.ifalse ) return - ! Initialize any derived hydraulics parameters - ! P-V curve: total RWC @ which elastic drainage begins [-] - ! real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) - ! P-V curve: total RWC @ which capillary reserves exhausted - ! real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + if ( hlm_use_planthydro.eq.ifalse ) return -! call InitAllocatePlantMedia(n_porous_media) -! call SetPlantMediaParam(leaf_p_media, rwcft_in=1._r8, rwccap_in=1._r8) -! call SetPlantMediaParam(stem_p_media, rwcft_in=0.958_r8, rwccap_in=0.947_r8) -! call SetPlantMediaParam(troot_p_media, rwcft_in=0.958_r8, rwccap_in=0.947_r8) -! call SetPlantMediaParam(aroot_p_media, rwcft_in=0.958_r8, rwccap_in=0.947_r8) + ! Initialize any derived hydraulics parameters nsites = ubound(sites,1) do s=1,nsites @@ -1277,65 +1228,7 @@ subroutine InitHydrSites(sites,bc_in,numpft) sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil call sites(s)%si_hydr%InitHydrSite() - ! -------------------------------------------------------------------------------- - ! Initialize water transfer functions - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for soil! - ! -------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- - select case(soil_wrf_type) - case(van_genuchten) - do j=1,sites(s)%si_hydr%nlevsoi_hyd - allocate(wrf_vg) - csite_hydr%wrf_soil(j) => wrf_vg - wrf_vg%set_wrf_param_vg(alpha_in = alpha_vg, & - psd_in = psd_vg, & - th_sat_in = th_sat_vg, & - th_res_in = th_res_vg) - end do - case(campbell) - do j=1,sites(s)%si_hydr%nlevsoi_hyd - allocate(wrf_vg) - csite_hydr%wrf_soil(j) => wrf_cch - wrf_cch%set_wrf_param_cch(th_sat_in = bc_in(s)%watsat_sisl(j), & - psi_sat_in =(-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - beta_in = bc_in(s)%bsw_sisl(j)) - end do - case(tfs) - write(fates_log(),*) 'TFS water retention curves not available for soil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(soil_wkf_type) - case(van_genuchten) - do j=1,sites(s)%si_hydr%nlevsoi_hyd - allocate(wkf_vg) - csite_hydr%wkf_soil(j) => wkf_vg - wkf_vg%set_wkf_param_vg(alpha_in = alpha_vg, & - psd_in = psd_vg, & - th_sat_in = th_sat_vg, & - th_res_in = th_res_vg, & - tort_in = th_tort_vg) - end do - case(campbell) - do j=1,sites(s)%si_hydr%nlevsoi_hyd - allocate(wkf_cch) - csite_hydr%wkf_soil(j) => wkf_cch - wkf_cch%set_wkf_param_cch(th_sat_in = bc_in(s)%watsat_sisl(j), & - psi_sat_in = (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - beta_in = bc_in(s)%bsw_sisl(j)) - end do - case(tfs) - write(fates_log(),*) 'TFS conductance not used in soil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select end do @@ -1358,6 +1251,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) integer :: nsites integer :: nlevsoil ! Number of soil layers integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch + nsites = ubound(sites,1) @@ -1384,17 +1282,64 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do end if - do j = 1, nlevsoil_hyd - ! Calculate the matric potential on the innner shell (this is used to initialize - ! xylem and root pressures in new cohorts) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm, & - bc_in(s)%bsw_sisl(j), smp) + site_hydr%l_aroot_layer(1:site_hydr%nlevsoi_hyd) = 0.0_r8 + + + ! -------------------------------------------------------------------------------- + ! Initialize water transfer functions + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for soil! + ! -------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wrf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_vg) + site_hydr%wrf_soil(j)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wrf_cch) + site_hydr%wrf_soil(j)%p => wrf_cch + call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS water retention curves not available for soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wkf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_vg) + site_hydr%wkf_soil(j)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevsoi_hyd + allocate(wkf_cch) + site_hydr%wkf_soil(j)%p => wkf_cch + call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j)]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS conductance not used in soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + - site_hydr%psisoi_liq_innershell(j) = smp - end do - site_hydr%l_aroot_layer(1:site_hydr%nlevsoi_hyd) = 0.0_r8 end do @@ -1645,23 +1590,9 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) end do do j=1,csite_hydr%nlevsoi_hyd - select case (iswc) - case (van_genuchten) - write(fates_log(),*) & - 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in%smpmin_si*denh2o*grav_earth*1.e-9_r8, & - (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in%bsw_sisl(j), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in%watsat_sisl(j), & - watres_local) + + watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) - - case default - end select total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) @@ -1888,31 +1819,15 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) csite_hydr => currentSite%si_hydr if(.false.) then - ! calculate initial s, psi by layer and shell + do j = 1, csite_hydr%nlevsoi_hyd ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - select case (iswc) - case (van_genuchten) - do k = 1,nshell - s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) - write(fates_log(),*) 'VG is not available yet' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call swcVG_psi_from_satfrac(s_shell_init(j,k),alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),psi_shell_init(j,k)) - end do - case (campbell) - do k = 1,nshell - s_shell_init(j,k) = (csite_hydr%h2osoi_liqvol_shell(j,k) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j) - bc_in%watres_sisl(j)) - call swcCampbell_psi_from_satfrac( s_shell_init(j,k), & - bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in%bsw_sisl(j),psi_shell_init(j,k)) - end do - case default - write(fates_log(),*) 'Somehow you picked a PT function that DNE' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + + do k = 1,nshell + psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) + end do + end if !has l_aroot_coh changed? enddo @@ -1971,25 +1886,9 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) do j = 1,csite_hydr%nlevsoi_hyd ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - select case (iswc) - case (van_genuchten) - do k = 1,nshell - write(fates_log(),*) 'VG is not available yet' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! call swcVG_satfrac_from_psi(psi_shell_interp(j,k), & - ! alpha_VG(c,j),n_VG(c,j),m_VG(c,j),l_VG(c,j),s_shell_interp(j,k)) - enddo - case (campbell) - do k = 1,nshell - call swcCampbell_satfrac_from_psi(psi_shell_interp(j,k), & - (-1._r8)*bc_in%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in%bsw_sisl(j), & - s_shell_interp(j,k)) - end do - case default - write(fates_log(),*) 'Somehow you picked a PT function that DNE' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + + s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j)) / & + (bc_in%watres_sisl(j)+bc_in%watres_sisl(j)) end if !has l_aroot_coh changed? enddo @@ -2295,7 +2194,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! hydraulics global constants - real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] + real(r8), parameter :: small_theta_num = 1.e-5_r8 ! avoids theta values equalling thr or ths [m3 m-3] ! hydraulics timestep adjustments for acceptable water balance error @@ -2331,6 +2230,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: wb_error_site ! Error reflecting difference between site storage before and after ! integration, with the change in the uptake boundary condition ! that we send to the HLM. [kg/m2] + real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation + ! or sub-residual water contents from occuring in the soil [kg/m2] + ! hydraulics other integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered @@ -2550,12 +2452,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Special case. Maximum conductance depends on the ! potential gradient (same elevation, no geopotential ! required. - - psi_inner_shell = psi_from_th(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), & ! optional for soil - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) ! optional for soil + + psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) ! Note, since their is no elevation difference between @@ -2568,12 +2466,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) end if ! Get matric potential [Mpa] of the absorbing root - psi_aroot = psi_from_th(ccohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j)) + psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) ! Get Fraction of Total Conductivity [-] of the absorbing root - ftc_aroot = flc_from_psi(ccohort%pft, aroot_p_media, & - ccohort_hydr%th_aroot(j), psi_aroot) + ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) ! Calculate total effective conductance over path [kg s-1 MPa-1] ! from absorbing root node to 1st rhizosphere shell @@ -2588,18 +2484,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant + + psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) - psi_shell = psi_from_th(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,k), & - bc_in(s)%watsat_sisl(j), & ! optional for soil - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) - - ftc_shell = flc_from_psi(ccohort%pft, rhiz_p_media, & - site_hydr%h2osoi_liqvol_shell(j,k), & - psi_shell, & - bc_in(s)%sucsat_sisl(j), & ! optional for soil - bc_in(s)%bsw_sisl(j)) ! optional for soil + ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) if(k ccohort%shorter enddo !cohort @@ -2758,74 +2627,62 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo !patch + + ! Calculate the amount of water fluxing through the roots. It is the sum + ! of the change in thr rhizosphere shells. Note that following this calculation + ! we may adjust the change in soil water to avoid super-saturation and sub-residual + ! water contents. But the pre-adjusted value is the actual amount of root flux. + + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + + ! In this section we evaluate the water content in the rhizosphere ! and apply constraints, so that the water contents are not above saturation ! or below residual. site_hydr%supsub_flag(:) = 999 + supsub_error = 0._r8 do j=1,site_hydr%nlevsoi_hyd - !! BOC... should the below code exist on HLM side? watres_col is a new SWC parameter - ! introduced for the van Genuchten, but does not exist for Campbell SWC. - select case (iswc) - case (van_genuchten) - write(fates_log(),*) 'Van Genuchten plant hydraulics is inoperable until further notice' - call endrun(msg=errMsg(sourcefile, __LINE__)) - ! watres_local = bc_in(s)%watres_sisl(j) - case (campbell) - call swcCampbell_satfrac_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*1.e-9_r8, & - (-1._r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), & - tmp1) - call swcCampbell_th_from_satfrac(tmp1, & - bc_in(s)%watsat_sisl(j), & - watres_local) - case default - end select + + watres_local = site_hydr%wrf_soil(j)%p%th_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) + do k=1,nshell -! if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & -! (bc_in(s)%watsat_sisl(j)-small_theta_num)) then -!! site_hydr%supsub_flag(j) = k -! site_hydr%h2osoi_liqvol_shell(j,k) = bc_in(s)%watsat_sisl(j)-small_theta_num -!! else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & -!! (watres_local+small_theta_num)) then -!! site_hydr%supsub_flag(j) = -k -!! site_hydr%h2osoi_liqvol_shell(j,k) = watres_local+small_theta_num -! else - site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & - dth_layershell_col(j,k) -! end if - enddo + if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & + (bc_in(s)%watsat_sisl(j)-small_theta_num)) then - if(debug)then - mean_theta = sum(site_hydr%h2osoi_liqvol_shell(j,:)*site_hydr%v_shell(j,:))/sum(site_hydr%v_shell(j,:)) - if( (mean_theta < watres_local) ) then - write(fates_log(),*) 'Mean soil layer water content, post fates-hydro integration, below residual.' - write(fates_log(),*) 'layer: ',j - write(fates_log(),*) 'theta res: ',watres_local,' [m3/m3]' - write(fates_log(),*) 'mean theta: ',mean_theta - write(fates_log(),*) 'theta: ',site_hydr%h2osoi_liqvol_shell(j,:) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (mean_theta > bc_in(s)%watsat_sisl(j) ) then - write(fates_log(),*) 'Mean soil layer water content, post fates-hydro integration, above saturation.' - write(fates_log(),*) 'layer: ',j - write(fates_log(),*) 'theta sat: ', bc_in(s)%watsat_sisl(j),' [m3/m3]' - write(fates_log(),*) 'mean theta: ',mean_theta - write(fates_log(),*) 'theta: ',site_hydr%h2osoi_liqvol_shell(j,:) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Update the matric potential in the inner-most shell - ! (used for setting tissue potentials of new recruits) - call swcCampbell_psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1), & - bc_in(s)%watsat_sisl(j), (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*1.e-9_r8, & - bc_in(s)%bsw_sisl(j), smp) - site_hydr%psisoi_liq_innershell(j) = smp + ! We are destroying water in this case [kg/m2] + supsub_error = supsub_error - site_hydr%v_shell(j,k)*denh2o*AREA_INV* & + (site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k) - (bc_in(s)%watsat_sisl(j)-small_theta_num)) + + ! Change dth_layer_shell to reflect the bounded soil moisture + dth_layershell_col(j,k) = (bc_in(s)%watsat_sisl(j)-small_theta_num) - site_hydr%h2osoi_liqvol_shell(j,k) + + ! Flag that a superaturation problem was encountered here + site_hydr%supsub_flag(j) = k + + else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & + (watres_local+small_theta_num)) then + + ! We are creating water [kg/m2] + supsub_error = supsub_error + site_hydr%v_shell(j,k)*denh2o*AREA_INV* & + ((watres_local+small_theta_num) - (site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k))) + + ! Change dth_layer_shell to reflect the bounded soil moisture + dth_layershell_col(j,k) = ( watres_local+small_theta_num ) - site_hydr%h2osoi_liqvol_shell(j,k) + + ! Flag that a super-saturation problem was encountered here + site_hydr%supsub_flag(j) = -k + + end if + + site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & + dth_layershell_col(j,k) + enddo + !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) - bc_out(s)%qflx_soil2root_sisl(j) = & + bc_out(s)%qflx_soil2root_sisl(j) = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) @@ -2839,10 +2696,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo !site_hydr%nlevsoi_hyd - - root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - - delta_plant_storage = site_hydr%h2oveg - delta_plant_storage delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & @@ -2857,7 +2710,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(abs(delta_soil_storage + root_flux) > 1.e-6_r8 ) then + if(abs(delta_soil_storage + root_flux - supsub_error) > 1.e-6_r8 ) then write(fates_log(),*) 'Site soil water balance does not close' write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' @@ -2879,7 +2732,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) wb_error_site = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - transp_flux) - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site + supsub_error bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & site_hydr%h2oveg_growturn_err - & @@ -3207,8 +3060,8 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Locals - integer :: inode ! node index "i" - integer :: jpath ! path index "j" + integer :: i ! node index "i" + integer :: j ! path index "j" integer :: itest ! node index used for testing and reporting errors integer :: ishell ! rhizosphere shell index of the node integer :: ishell_up ! rhizosphere shell index on the upper side of flow path @@ -3254,9 +3107,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] integer :: error_code ! flag that specifies which check tripped a failed solution - - logical :: test_exit - + integer :: ft ! plant functional type real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) @@ -3288,7 +3139,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! site_hydr%l_aroot_layer(ilayer) is units [m/site] aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) - + + + ft = cohort%pft ! If in "spatially parallel" mode, scale down cross section ! of flux through top by the root fraction of this layer @@ -3316,26 +3169,26 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! For all nodes leaf through rhizosphere ! Send node heights and compartment volumes to a node-based array - do inode = 1,n_hypool_tot - - if (inode<=n_hypool_ag) then - z_node(inode) = cohort_hydr%z_node_ag(inode) - v_node(inode) = cohort_hydr%v_ag(inode) - th_node_init(inode) = cohort_hydr%th_ag(inode) - elseif (inode==n_hypool_ag+1) then - z_node(inode) = cohort_hydr%z_node_troot - v_node(inode) = cohort_hydr%v_troot - th_node_init(inode) = cohort_hydr%th_troot - elseif (inode==n_hypool_ag+2) then - z_node(inode) = -bc_in%z_sisl(ilayer) - v_node(inode) = cohort_hydr%v_aroot_layer(ilayer) - th_node_init(inode) = cohort_hydr%th_aroot(ilayer) + do i = 1,n_hypool_tot + + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i==n_hypool_ag+1) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + elseif (i==n_hypool_ag+2) then + z_node(i) = -bc_in%z_sisl(ilayer) + v_node(i) = cohort_hydr%v_aroot_layer(ilayer) + th_node_init(i) = cohort_hydr%th_aroot(ilayer) else - ishell = inode-(n_hypool_ag+2) - z_node(inode) = -bc_in%z_sisl(ilayer) + ishell = i-(n_hypool_ag+2) + z_node(i) = -bc_in%z_sisl(ilayer) ! The volume of the Rhizosphere for a single plant - v_node(inode) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant - th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) + v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant + th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) end if end do @@ -3348,8 +3201,6 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t iter = 0 do while( .not.solution_found ) - - test_exit = .false. ! These are diagnostics that must be calculated. ! in this routine (uses differentials and actual fluxes) @@ -3393,54 +3244,51 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t w_tot_beg = sum(th_node(:)*v_node(:))*denh2o ! Calculate on-node quantities: potential, and derivatives - do inode = 1,n_hypool_tot + do i = 1,n_hypool_plant ! Get matric potential [Mpa] - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) ! Get total potential [Mpa] - h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) ! Get Fraction of Total Conductivity [-] - ftc_node(inode) = flc_from_psi(cohort%pft, porous_media(inode), & - th_node(inode), & - psi_node(inode), & - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - ! deriv ftc wrt theta - dpsi_dtheta_node(inode) = dpsidth_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - dftc_dpsi = dflcdpsi_from_psi(cohort%pft, porous_media(inode), & - th_node(inode), & - psi_node(inode), & - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil - - dftc_dtheta_node(inode) = dftc_dpsi * dpsi_dtheta_node(inode) + ftc_node(i) = wkf_plant(p_media_nodes(i),ft)%p%ftc_from_psi(psi_node(i)) + + ! deriv psi wrt theta + dpsi_dtheta_node(i) = wrf_plant(p_media_nodes(i),ft)%p%dpsidth_from_th(th_node(i)) + + ! deriv ftc wrt psi + + dftc_dpsi = wkf_plant(p_media_nodes(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) ! We have two ways to calculate radial absorbing root conductance ! 1) Assume that water potential does not effect conductance ! 2) The standard FTC function applies - if(inode==n_hypool_ag+2)then + if(i==n_hypool_ag+2)then if(no_ftc_radialk) then - ftc_node(inode) = 1.0_r8 - dftc_dtheta_node(inode) = 0.0_r8 + ftc_node(i) = 1.0_r8 + dftc_dtheta_node(i) = 0.0_r8 end if end if end do + ! Same updates as loop above, but for rhizosphere shells + + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) + dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) + dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + end do + !-------------------------------------------------------------------------------- ! Part 2. Effective conductances over the path-length and Flux terms @@ -3450,7 +3298,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! Path is between the leaf node and first stem node ! ------------------------------------------------------------------------------- - jpath = 1 + j = 1 i_up = 1 i_lo = 2 kmax_up = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf @@ -3461,18 +3309,18 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) ! Path is between stem nodes ! ------------------------------------------------------------------------------- - do jpath=2,n_hypool_ag-1 + do j=2,n_hypool_ag-1 - i_up = jpath - i_lo = jpath+1 + i_up = j + i_lo = j+1 ! "Up" compartment is the "upper" node, but uses @@ -3489,18 +3337,18 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) end do ! Path is between lowest stem and transporting root - jpath = n_hypool_ag - i_up = jpath - i_lo = jpath+1 + j = n_hypool_ag + i_up = j + i_lo = j+1 kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper @@ -3509,9 +3357,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) ! Path is between the transporting root @@ -3519,9 +3367,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! NOTE: No need to scale by root fraction ! even if in parallel mode, already parallel! - jpath = n_hypool_ag+1 - i_up = jpath - i_lo = jpath+1 + j = n_hypool_ag+1 + i_up = j + i_lo = j+1 kmax_up = cohort_hydr%kmax_troot_lower(ilayer) kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) @@ -3530,17 +3378,17 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) ! Path is between the absorbing root ! and the first rhizosphere shell nodes - jpath = n_hypool_ag+2 - i_up = jpath - i_lo = jpath+1 + j = n_hypool_ag+2 + i_up = j + i_lo = j+1 ! Special case. Maximum conductance depends on the ! potential gradient. @@ -3559,17 +3407,17 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) ! Path is between rhizosphere shells - do jpath = n_hypool_ag+3,n_hypool_tot-1 + do j = n_hypool_ag+3,n_hypool_tot-1 - i_up = jpath - i_lo = jpath+1 + i_up = j + i_lo = j+1 ishell_up = i_up - (n_hypool_ag+2) ishell_lo = i_lo - (n_hypool_ag+2) @@ -3581,9 +3429,9 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t h_node(i_lo),h_node(i_up), & dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(jpath), & - A_term(jpath), & - B_term(jpath)) + k_eff(j), & + A_term(j), & + B_term(j)) end do @@ -3599,22 +3447,22 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - do inode = 2,n_hypool_tot-1 - jpath = inode - tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = A_term(jpath) - B_term(jpath-1) - denh2o*v_node(inode)/dt_substep - tris_c(inode) = B_term(jpath) - tris_r(inode) = -k_eff(jpath)*(h_node(inode+1)-h_node(inode)) + & - k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + do i = 2,n_hypool_tot-1 + j = i + tris_a(i) = -A_term(j-1) + tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = B_term(j) + tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & + k_eff(j-1)*(h_node(i)-h_node(i-1)) end do - inode = n_hypool_tot - jpath = n_hypool_tot - tris_a(inode) = -A_term(jpath-1) - tris_b(inode) = -B_term(jpath-1) - denh2o*v_node(inode)/dt_substep - tris_c(inode) = 0._r8 - tris_r(inode) = k_eff(jpath-1)*(h_node(inode)-h_node(inode-1)) + i = n_hypool_tot + j = n_hypool_tot + tris_a(i) = -A_term(j-1) + tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = 0._r8 + tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) ! Calculate the change in theta @@ -3647,19 +3495,26 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t error_code = 0 end if - ! Calculate new psi - do inode = 1,n_hypool_tot - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + ! Extra checks + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if + + ! Calculate new psi for checks + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) + end do + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) end do + ! We currently allow super-saturation, but draw the line ! at 100% of volume... if( any(th_node(:)>1.0_r8) ) then - test_exit = .true. solution_found = .false. error_code = 2 error_arr(:) = th_node(:) @@ -3668,25 +3523,16 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! We dont allow any super-saturaiton in soil nodes if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then - test_exit = .true. solution_found = .false. error_code = 4 error_arr(:) = th_node(:) exit end if - ! Extra checks - if( any(th_node(:)<0._r8) ) then - test_exit = .true. - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if + ! Check if any psi values are > 0 !if(any(psi_node(:) > nearzero)) then - ! test_exit = .true. ! solution_found = .false. ! error_code = 4 ! error_arr(:) = psi_node(:) @@ -3705,38 +3551,32 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t ! (note: a path j is between node i and i+1) ! [kg] = [kg/s] * [s] - inode = n_hypool_ag + i = n_hypool_ag sapflow = sapflow + dt_substep * & - (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) - A_term(inode)*dth_node(inode) + & ! dq at node i - B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 ! Root uptake is the integrated flux between the first rhizosphere ! shell and the absorbing root - inode = n_hypool_ag+2 + i = n_hypool_ag+2 rootuptake = rootuptake + dt_substep * & - (k_eff(inode)*(h_node(inode+1)-h_node(inode)) + & ! flux at (t) - A_term(inode)*dth_node(inode) + & ! dq at node i - B_term(inode)*dth_node(inode+1)) ! dq at node i+1 + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 ! If debug mode is on, lets also track the mass fluxes across each ! path, and keep a running average of the effective conductances if(debug)then - do jpath=1,n_hypool_tot-1 - k_diag(jpath) = k_diag(jpath) + k_eff(jpath)*dt_substep/dt_step - flux_diag(jpath) = flux_diag(jpath) + dt_substep * ( & - k_eff(jpath)*(h_node(jpath+1)-h_node(jpath)) + & - A_term(jpath)*dth_node(jpath)+ B_term(jpath)*dth_node(jpath+1)) + do j=1,n_hypool_tot-1 + k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step + flux_diag(j) = flux_diag(j) + dt_substep * ( & + k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) end do end if - if(test_exit)then - print*,"Loop exit broken?" - stop - end if - - end do ! do istep = 1,nsteps (substep loop) iter=iter+1 @@ -3848,15 +3688,16 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & write(fates_log(),*) 'error code: ',err_code write(fates_log(),*) 'error diag: ',err_arr(:) - do inode = 1,n_hypool_tot - psi_node(inode) = psi_from_th(cohort%pft, porous_media(inode), & - th_node(inode), & - bc_in%watsat_sisl(ilayer), & ! optional for soil - bc_in%sucsat_sisl(ilayer), & ! optional for soil - bc_in%bsw_sisl(ilayer)) ! optional for soil + do inode = 1,n_hypool_plant + psi_node(inode) = wrf_plant(p_media_nodes(inode),ft)%p%psi_from_th(th_node(inode)) + h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + end do + do inode = n_hypool_plant+1,n_hypool_tot + psi_node(inode) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(inode)) h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) end do + leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & @@ -3877,9 +3718,9 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) write(fates_log(),*) 'vol, theta, H, kmax-' write(fates_log(),*) 'flux: ', q_top_eff*dt_step - write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1) + write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1),psi_node(1) write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler - write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2) + write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2),psi_node(2) write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) @@ -3956,9 +3797,9 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & ! ----------------------------------------------------------------------------- real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] + real(r8) :: ftc_lo, ftc_up ! frac total conductance [-] real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] - real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative + real(r8) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative ! of FTC wrt relative water content real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential ! wrt relative water content @@ -3967,22 +3808,47 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & real(r8),intent(out) :: b_term ! "B" term for path (See tech note) real(r8) :: h_diff ! Total potential difference [MPa] - - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_lo*kmax_lo)) + logical, parameter :: do_upstream_k = .true. ! the effective fraction of total + ! conductivity is either governed + ! by the upstream node, or by both + ! with a harmonic average ! Calculate difference in total potential over the path [MPa] h_diff = h_lo - h_up + + ! If we do enable "upstream K", then we are saying that + ! the fractional loss of conductivity is dictated + ! by the upstream side of the flow. In this case, + ! the change in ftc is only non-zero on that side, and is + ! zero'd otherwise. + + if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_up = ftc_lo + dftc_dtheta_up = 0._r8 + else + ftc_lo = ftc_up + dftc_dtheta_lo = 0._r8 + end if + + end if + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_lo*kmax_lo)) + + ! "A" term, which operates on the upper node (closer to atm) a_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & * dftc_dtheta_up - k_eff * dpsi_dtheta_up + ! "B" term, which operates on the lower node (further from atm) b_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo - - + + return end subroutine GetImTaylorKAB @@ -4082,7 +3948,411 @@ subroutine RecruitWaterStorage(nsites,sites,bc_out) return end subroutine RecruitWaterStorage + ! ===================================================================================== + + ! ===================================================================================== + ! Utility Functions + ! ===================================================================================== + + subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] + real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] + real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] + real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] + real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] + real(r8) , intent(out) :: x_new ! soil depth [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: lower ! lower bound x estimate [m] + real(r8) :: upper ! upper bound x estimate [m] + real(r8) :: y_lo ! corresponding y value at lower + real(r8) :: f_lo ! y difference between lower bound guess and target y + real(r8) :: y_hi ! corresponding y value at upper + real(r8) :: f_hi ! y difference between upper bound guess and target y + real(r8) :: y_new ! corresponding y value at x.new + real(r8) :: f_new ! y difference between new y guess at x.new and target y + real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + !---------------------------------------------------------------------- + + lower = lower_init + upper = upper_init + f_lo = zeng2001_crootfr(a, b, lower) - crootfr + f_hi = zeng2001_crootfr(a, b, upper) - crootfr + chg = upper - lower + do while(abs(chg) .gt. xtol) + x_new = 0.5_r8*(lower + upper) + f_new = zeng2001_crootfr(a, b, x_new) - crootfr + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower + end do + end subroutine bisect_rootfr + + ! ===================================================================================== + + function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: + real(r8) , intent(in) :: a,b ! pft parameters + real(r8) , intent(in) :: z ! soil depth (m) + real(r8) , intent(in), optional :: z_max ! max soil depth (m) + ! + real(r8) :: crootfr_max + + ! !RESULT + real(r8) :: crootfr ! cumulative root fraction + ! + !------------------------------------------------------------------------ + crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + + + ! If a maximum rooting depth is provided, then + ! we force everything to sum to unity. We do this by + ! simply dividing through by the maximum possible + ! root fraction. + + if(present(z_max))then + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max + end if + + if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max + end if + end if + end if + + + return + + end function zeng2001_crootfr + + ! ===================================================================================== + + subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: + + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots + ! for the whole site, this layer (m) + real(r8) , intent(in) :: rs1 ! Fine root radius (m) + real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) + real(r8) , intent(in) :: dz ! Width of current soil layer (m) + real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) + real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint + real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) + ! for this layer + ! + ! !LOCAL VARIABLES: + integer :: k ! rhizosphere shell indicies + integer :: nshells ! We don't use the global because of unit testing + !----------------------------------------------------------------------- + + nshells = size(r_out_shell,dim=1) + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + enddo + end if + + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + + do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo + ! update volumes + do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + + + end subroutine shellGeom + + ! ===================================================================================== + + function xylemtaper(p, dz) result(chi_tapnotap) + + ! !ARGUMENTS: + real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent [-] + real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) + real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) + ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) + ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. + ! Hydraulic trade-offs and space filling enable better predictions of vascular structure + ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. + real(r8) :: lN=0.04_r8 ! petiole length [m] + real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] + real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] + real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: num ! temporary + real(r8) :: den ! temporary + ! + ! !RESULT + real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz + ! + !------------------------------------------------------------------------ + + anotap = 7.19903e-13_r8 + bnotap = 1.326105578_r8 + if (p >= 1.0_r8) then + btap = 2.00586217_r8 + atap = 1.82513E-12_r8 + else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then + btap = 1.854812819_r8 + atap = 6.66908E-13_r8 + else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then + btap = 1.628179741_r8 + atap = 6.58345E-13_r8 + else + btap = bnotap + atap = anotap + end if + + num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) + den = log(little_n) + big_n = num/den - 1._r8 + ktap = atap * (little_n**(big_N* btap/2._r8)) + knotap = anotap * (little_n**(big_N*bnotap/2._r8)) + chi_tapnotap = ktap / knotap + + return + + end function xylemtaper + + ! ===================================================================================== + + subroutine Hydraulics_Tridiagonal(a, b, c, r, u) + ! + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 + ! + ! This solves the form: + ! + ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) + ! + ! It assumed that coefficient a(1) and c(N) DNE as there is + ! no u(0) or u(N-1). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix + real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix + real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix + real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix + real(r8), intent(out) :: u(:) ! solution + ! + ! !LOCAL VARIABLES: + real(r8) :: bet ! temporary + real(r8) :: gam(10) ! temporary + integer :: k ! index + integer :: N ! Size of the matrix + real(r8) :: err ! solution error, in units of [m3/m3] + real(r8) :: rel_err ! relative error, normalized by delta theta + real(r8), parameter :: allowable_rel_err = 0.0001_r8 + + ! real(r8), parameter :: allowable_err = 1.e-6_r8 + !---------------------------------------------------------------------- + N=size(r,dim=1) + bet = b(1) + do k=1,N + if(k == 1) then + u(k) = r(k) / bet + else + gam(k) = c(k-1) / bet + bet = b(k) - a(k) * gam(k) + u(k) = (r(k) - a(k)*u(k-1)) / bet + end if + enddo + + do k=N-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) + enddo + + ! If debug mode, calculate error on the forward solution + if(debug)then + do k=1,N + + if(k==1)then + err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) + elseif(knearzero)then + rel_err = abs(err/u(k)) + + if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end do + end if + + end subroutine Hydraulics_Tridiagonal + + + + subroutine InitHydroGlobals() + + ! This routine allocates the Water Transfer Functions (WTFs) + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for plants! These functions have specific + ! parameters, potentially, for each plant functional type and + ! each organ (pft x organ), but this can be used globally (across + ! all sites on the node (machine) to save memory. These functions + ! are also applied to soils, but since soil properties vary with + ! soil layer and location, those functions are bound to the site + ! structure, and are therefore not "global". + + ! Define + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wkf_type_tfs), pointer :: wkf_tfs + + integer :: ft ! PFT index + integer :: pm ! plant media index + integer :: inode ! compartment node index + + + if(hlm_use_planthydro.eq.ifalse) return + + ! we allocate from stomata_p_media, which should be zero + + allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) + allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wrf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + end do + case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger retention curves ' + write(fates_log(),*) 'are not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs_type) + write(fates_log(),*) 'TFS water retention curves not yet added to plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wkf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + + end do + case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + end do + end select + + ! There is only 1 stomata conductance hypothesis which uses the p50 and + ! vulnerability parameters + ! ----------------------------------------------------------------------------------- + + do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) + end do + + ! Create a lookup table that gives the porous media index from the node index + allocate(p_media_nodes(n_hypool_tot)) + + do inode = 1,n_hypool_leaf + p_media_nodes(inode) = leaf_p_media + end do + + do inode = n_hypool_leaf+1,n_hypool_leaf+n_hypool_ag + p_media_nodes(inode) = stem_p_media + end do + + inode = n_hypool_ag+1 + p_media_nodes(inode) = troot_p_media + + inode = n_hypool_ag+2 + p_media_nodes(inode) = aroot_p_media + + do inode = n_hypool_ag+3,n_hypool_tot + p_media_nodes(inode) = rhiz_p_media + end do + + + return + end subroutine InitHydroGlobals !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 5927f7cc62..21eef78b0f 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -57,7 +57,7 @@ dpsidth_from_th.restype = c_double ftc_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapftcfrompsi ftc_from_psi.restype = c_double -dftcdpsi_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapftcfrompsi +dftcdpsi_from_psi = f90_hydrounitwrap_obj.__hydrounitwrapmod_MOD_wrapdftcdpsi dftcdpsi_from_psi.restype = c_double @@ -199,49 +199,47 @@ def main(argv): alphas = [1.0, 1.0, 1.0, 1.0] psds = [2.7, 2.7, 2.7, 2.7] tort = [0.5, 0.5, 0.5, 0.5] + avuln = [2.0, 2.0, 2.5, 2.5] + p50 = [-1.5, -1.5, -2.25, -2.25] - nwrf = 4 - nwkf = 2 + ncomp= 4 # Allocate memory to our objective classes - iret = initalloc_wtfs(ci(nwrf),ci(nwkf)) + iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) print('Allocated') # Push parameters to those classes # ------------------------------------------------------------------------- # Generic VGs - init_wrf_args = (4 * c_double)(alphas[0],psds[0],th_sats[0],th_ress[0]) # alpha, psd, th_sat, th_res - iret = setwrf(ci(1),ci(1),ci(len(init_wrf_args)),byref(init_wrf_args)) + init_wrf_args = [alphas[0],psds[0],th_sats[0],th_ress[0]] # alpha, psd, th_sat, th_res + iret = setwrf(ci(1),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) - init_wrf_args = (4 * c_double)(alphas[1],psds[1],th_sats[1],th_ress[1]) # alpha, psd, th_sat, th_res - iret = setwrf(ci(2),ci(1),ci(len(init_wrf_args)),byref(init_wrf_args)) - - init_wrf_args = (4 * c_double)(alphas[2],psds[2],th_sats[2],th_ress[2]) # alpha, psd, th_sat, th_res - iret = setwrf(ci(3),ci(1),ci(len(init_wrf_args)),byref(init_wrf_args)) - - init_wrf_args = (4 * c_double)(alphas[3],psds[3],th_sats[3],th_ress[3]) # alpha, psd, th_sat, th_res - iret = setwrf(ci(4),ci(1),ci(len(init_wrf_args)),byref(init_wrf_args)) + init_wrf_args = [alphas[1],psds[1],th_sats[1],th_ress[1]] # alpha, psd, th_sat, th_res + iret = setwrf(ci(2),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + init_wrf_args = [alphas[2],psds[2],th_sats[2],th_ress[2]] # alpha, psd, th_sat, th_res + iret = setwrf(ci(3),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + init_wrf_args = [alphas[3],psds[3],th_sats[3],th_ress[3]] # alpha, psd, th_sat, th_res + iret = setwrf(ci(4),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) print('initialized WRF') theta = np.linspace(0.10, 0.7, num=npts) + psi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) + dpsidth = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) + cdpsidth = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) - psi = np.full(shape=(nwrf,len(theta)),dtype=np.float64,fill_value=np.nan) - dpsidth = np.full(shape=(nwrf,len(theta)),dtype=np.float64,fill_value=np.nan) - cdpsidth = np.full(shape=(nwrf,len(theta)),dtype=np.float64,fill_value=np.nan) - - for ic in range(nwrf): + for ic in range(ncomp): for i,th in enumerate(theta): psi[ic,i] = psi_from_th(ci(ic+1),c8(th)) fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) - for ic in range(nwrf): + for ic in range(ncomp): ax1.plot(theta,psi[ic,:]) ax1.set_ylim((-10,5)) @@ -249,14 +247,14 @@ def main(argv): ax1.set_xlabel('VWC [m3/m3]') - for ic in range(nwrf): + for ic in range(ncomp): for i in range(1,len(theta)-1): dpsidth[ic,i] = dpsidth_from_th(ci(ic+1),c8(theta[i])) cdpsidth[ic,i] = (psi[ic,i+1]-psi[ic,i-1])/(theta[i+1]-theta[i-1]) fig1, ax1 = plt.subplots(1,1,figsize=(9,6)) - for ic in range(nwrf): + for ic in range(ncomp): ax1.plot(theta,dpsidth[0,:],label='func') ax1.plot(theta,cdpsidth[0,:],label='check') ax1.set_ylim((0,1000)) @@ -264,23 +262,79 @@ def main(argv): ax1.set_ylabel('dPSI/dTh [MPa m3 m-3]') ax1.set_xlabel('VWC [m3/m3]') ax1.legend(loc='upper right') - plt.show() + # Push parameters to WKF classes # ------------------------------------------------------------------------- # Generic VGs - init_wkf_args = c8_arr(alphas[0],psds[0],th_sats[0],th_ress[0],tort[0]) # alpha, psd, th_sat, th_res - iret = setwkf(ci(1),ci(1),ci(len(init_wkf_args)),byref(init_wkf_args)) + init_wkf_args = [alphas[0],psds[0],th_sats[0],th_ress[0],tort[0]] # alpha, psd, th_sat, th_res + iret = setwkf(ci(1),ci(1),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + init_wkf_args = [th_sats[0],p50[0],avuln[0]] + iret = setwkf(ci(2),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + init_wkf_args = [th_sats[1],p50[1],avuln[1]] + iret = setwkf(ci(3),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + init_wkf_args = [th_sats[2],p50[2],avuln[2]] + iret = setwkf(ci(4),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + ftc = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) + dftcdpsi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) + cdftcdpsi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) + + + for ic in range(ncomp): + for i in range(0,len(theta)): + ftc[ic,i] = ftc_from_psi(ci(ic+1),c8(psi[ic,i])) + + for ic in range(ncomp): + for i in range(1,len(theta)-1): + dftcdpsi[ic,i] = dftcdpsi_from_psi(ci(ic+1),c8(psi[ic,i])) + cdftcdpsi[ic,i] = (ftc[ic,i+1]-ftc[ic,i-1])/(psi[ic,i+1]-psi[ic,i-1]) + + + + fig2, ax1 = plt.subplots(1,1,figsize=(9,6)) + for ic in range(ncomp): + ax1.plot(psi[ic,:],ftc[ic,:],label='{}'.format(ic+1)) + + ax1.set_ylabel('FTC') + ax1.set_xlabel('Psi [MPa]') + ax1.set_xlim([-10,3]) + ax1.legend(loc='upper right') + + + + fig3,ax1 = plt.subplots(1,1,figsize=(9,6)) + for ic in range(ncomp): + ax1.plot(psi[ic,:],abs(dftcdpsi[ic,:]-cdftcdpsi[ic,:])/abs(cdftcdpsi[ic,:]),label='{}'.format(ic)) +# ax1.plot(psi[ic,:],cdftcdpsi[ic,:],label='check') + + ax1.set_ylabel('dFTC/dPSI') + ax1.set_xlabel('Psi [MPa]') + ax1.set_xlim([-30,3]) +# ax1.set_ylim([0,10]) + ax1.legend(loc='upper right') + plt.show() code.interact(local=dict(globals(), **locals())) + + + + + + exit(0) + + # Test 1 For a set of thetas, calculate psi for each pm. # =================================================================================== diff --git a/functional_unit_testing/shared/py_src/PyF90Utils.py b/functional_unit_testing/shared/py_src/PyF90Utils.py index 8d0519e84c..49965e794c 100644 --- a/functional_unit_testing/shared/py_src/PyF90Utils.py +++ b/functional_unit_testing/shared/py_src/PyF90Utils.py @@ -1,6 +1,6 @@ import ctypes from ctypes import * - +import code # For development: code.interact(local=dict(globals(), **locals())) # These are shortcuts that simply convert real, ints and stings # into refernced cytype compliant arguments @@ -17,9 +17,13 @@ def cchar(fchar): return(byref(c_char(fchar))) +# We do NOT pass arrays back by reference +# This is because we will need to get their length +# on the argument + def c8_arr(r8_list): - return(byref((len(r8_list) * c_double)(r8_list))) + return(byref((len(r8_list) * c_double)(*r8_list))) def ci_arr(int_list): - return(byref((len(int_list) * c_int)(int_list))) + return(byref((len(int_list) * c_int)(*int_list))) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8b8545ec82..c12eb73d8d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -35,6 +35,7 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston + use EDTypesMod , only : element_pos use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_use_inventory_init @@ -64,6 +65,9 @@ module EDInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState + use FatesPlantHydraulicsMod, only : InitHydroGlobals + use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon +! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -80,12 +84,100 @@ module EDInitMod public :: init_site_vars public :: init_patches public :: set_site_properties + public :: InitFatesGlobals private :: init_cohorts + ! ============================================================================ contains + ! ============================================================================ + + ! ==================================================================================== + + subroutine InitFatesGlobals(masterproc) + + ! -------------------------------------------------------------------------- + ! This subroutine is simply a wrapper that calls various FATES modules + ! that initialize global objects, things, constructs, etc. Globals only + ! need to be set once during initialization, for each machine, and this + ! should not be called for forked SMP processes. + ! -------------------------------------------------------------------------- + + logical,intent(in) :: masterproc ! This is useful for reporting + ! and diagnostics so info is not printed + ! on numerous nodes to standard out. This + ! is not used to filter which machines + ! (nodes) to run these procedures, they + ! should be run on ALL nodes. + + ! Initialize PARTEH globals + ! (like the element lists, and mapping tables) + call InitPARTEHGlobals() + + ! Initialize Hydro globals + ! (like water retention functions) + call InitHydroGlobals() + + + return + end subroutine InitFatesGlobals + + ! ==================================================================================== + + + subroutine InitPARTEHGlobals() + + ! Initialize the Plant Allocation and Reactive Transport + ! global functions and mapping tables + ! Also associate the elements defined in PARTEH with a list in FATES + ! "element_list" is useful because it allows the fates side of the code + ! to loop through elements, and call the correct PARTEH interfaces + ! automatically. + + select case(hlm_parteh_mode) + case(prt_carbon_allom_hyp) + + num_elements = 1 + allocate(element_list(num_elements)) + element_list(1) = carbon12_element + element_pos(:) = 0 + element_pos(carbon12_element) = 1 + + call InitPRTGlobalAllometricCarbon() + + case(prt_cnp_flex_allom_hyp) + + num_elements = 3 + allocate(element_list(num_elements)) + element_list(1) = carbon12_element + element_list(2) = nitrogen_element + element_list(3) = phosphorus_element + element_pos(:) = 0 + element_pos(carbon12_element) = 1 + element_pos(nitrogen_element) = 2 + element_pos(phosphorus_element) = 3 + + !call InitPRTGlobalAllometricCNP() + write(fates_log(),*) 'You specified the allometric CNP mode' + write(fates_log(),*) 'with relaxed target stoichiometry.' + write(fates_log(),*) 'I.e., namelist parametre fates_parteh_mode = 2' + write(fates_log(),*) 'This mode is not available yet. Please set it to 1.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case DEFAULT + write(fates_log(),*) 'You specified an unknown PRT module' + write(fates_log(),*) 'Check your setting for fates_parteh_mode' + write(fates_log(),*) 'in the CLM namelist. The only valid value now is 1' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + end subroutine InitPARTEHGlobals + + ! ============================================================================ subroutine init_site_vars( site_in, bc_in ) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index afe16e667a..2da4be2c0a 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -1,10 +1,10 @@ module FatesHydraulicsMemMod use FatesConstantsMod, only : r8 => fates_r8 - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use FatesConstantsMod, only : itrue,ifalse - use FatesHydroWTFMod, only : wtf_type - + use FatesHydroWTFMod, only : wrf_arr_type + use FatesHydroWTFMod, only : wkf_arr_type implicit none private @@ -19,8 +19,8 @@ module FatesHydraulicsMemMod integer, parameter, public :: nlevsoi_hyd_max = 40 ! number of distinct types of plant porous media (leaf, stem, troot, aroot) - integer, parameter, public :: n_porous_media = 4 - + integer, parameter, public :: n_porous_media = 5 + integer, parameter, public :: n_plant_media = 4 integer, parameter, public :: n_hypool_leaf = 1 integer, parameter, public :: n_hypool_stem = 1 integer, parameter, public :: n_hypool_troot = 1 ! CANNOT BE CHANGED @@ -32,30 +32,18 @@ module FatesHydraulicsMemMod ! total number of water storage nodes integer, parameter, public :: n_hypool_tot = n_hypool_ag + n_hypool_troot + n_hypool_aroot + nshell + integer, parameter, public :: n_hypool_plant = n_hypool_tot - nshell + ! vector indexing the type of porous medium over an arbitrary number of plant pools + integer, parameter, public :: stomata_p_media = 0 integer, parameter, public :: leaf_p_media = 1 integer, parameter, public :: stem_p_media = 2 integer, parameter, public :: troot_p_media = 3 integer, parameter, public :: aroot_p_media = 4 - integer, parameter, public :: n_p_media = 4 ! This is just the number of plant - ! organ porous media types, does - ! not include soil - - ! This vector holds the identifiers for which porous media type is in the comaprtment - integer, parameter, public, dimension(n_hypool_tot) :: porous_media = (/leaf_p_media, & - stem_p_media, & - troot_p_media, & - aroot_p_media, & - rhiz_p_media, & - rhiz_p_media, & - rhiz_p_media, & - rhiz_p_media, & - rhiz_p_media /) - - ! number of previous timestep's leaf water potential to be retained - integer, parameter, public :: numLWPmem = 4 + integer, parameter, public :: rhiz_p_media = 5 + ! mirror of nlevcan, hard-set for simplicity, remove nlevcan_hyd on a rainy day ! Note (RGK): uscing nclmax causes annoying circular dependency (this needs EDTypes, EDTypes needs this) @@ -65,12 +53,6 @@ module FatesHydraulicsMemMod ! Mean fine root radius expected in the bulk soil real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 - ! Constant parameters (for time being, C2B is constant, - ! slated for addition to parameter file (RGK 08-2017)) - ! Carbon 2 biomass ratio - real(r8), parameter, public :: C2B = 2.0_r8 - - ! Derived parameters ! ---------------------------------------------------------------------------------------------- @@ -110,7 +92,7 @@ module FatesHydraulicsMemMod real(r8),allocatable :: rs1(:) ! Mean fine root radius (m) (currently a constant) - integer,allocatable :: supsub_flag(:) ! index of the outermost rhizosphere shell + integer, allocatable :: supsub_flag(:) ! index of the outermost rhizosphere shell ! encountering super- or sub-saturation real(r8),allocatable :: h2osoi_liqvol_shell(:,:) ! volumetric water in rhizosphere compartment (m3/m3) @@ -119,8 +101,6 @@ module FatesHydraulicsMemMod ! after root water has been extracted. This should ! be equal to the sum of the water over the rhizosphere shells - real(r8),allocatable :: psisoi_liq_innershell(:) ! Matric potential of the inner rhizosphere shell (MPa) - real(r8),allocatable :: recruit_w_uptake(:) ! recruitment water uptake (kg H2o/m2/s) @@ -150,8 +130,8 @@ module FatesHydraulicsMemMod ! support transpiration - class(wrf_type), pointer :: wrf_soil(:) ! Water retention function for soil layers - class(wkf_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil + class(wrf_arr_type), pointer :: wrf_soil(:) ! Water retention function for soil layers + class(wkf_arr_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil contains @@ -368,7 +348,6 @@ subroutine InitHydrSite(this) allocate(this%supsub_flag(1:nlevsoil_hyd)) ; this%supsub_flag = -999 allocate(this%h2osoi_liqvol_shell(1:nlevsoil_hyd,1:nshell)) ; this%h2osoi_liqvol_shell = nan allocate(this%h2osoi_liq_prev(1:nlevsoil_hyd)) ; this%h2osoi_liq_prev = nan - allocate(this%psisoi_liq_innershell(1:nlevsoil_hyd)); this%psisoi_liq_innershell = nan allocate(this%rs1(1:nlevsoil_hyd)); this%rs1(:) = fine_root_radius_const allocate(this%recruit_w_uptake(1:nlevsoil_hyd)); this%recruit_w_uptake = nan @@ -391,6 +370,9 @@ subroutine InitHydrSite(this) return end subroutine InitHydrSite + + + end module FatesHydraulicsMemMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 4b292f116a..aaf392048b 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -23,7 +23,6 @@ module FatesInterfaceMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : num_elements use EDTypesMod , only : element_list - use EDTypesMod , only : element_pos use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesGlobals , only : fates_global_verbose @@ -37,14 +36,8 @@ module FatesInterfaceMod use SFParamsMod , only : SpitFireCheckParams use EDParamsMod , only : FatesReportParams use EDParamsMod , only : bgc_soil_salinity - use PRTGenericMod , only : prt_carbon_allom_hyp - use PRTGenericMod , only : prt_cnp_flex_allom_hyp - use PRTGenericMod , only : carbon12_element - use PRTGenericMod , only : nitrogen_element - use PRTGenericMod , only : phosphorus_element - use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon - ! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP - + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -618,7 +611,6 @@ module FatesInterfaceMod public :: SetFatesTime public :: set_fates_global_elements public :: FatesReportParameters - public :: InitFatesGlobals public :: allocate_bcin public :: allocate_bcout @@ -1786,90 +1778,5 @@ subroutine FatesReportParameters(masterproc) return end subroutine FatesReportParameters - ! ==================================================================================== - - subroutine InitFatesGlobals(masterproc) - - ! -------------------------------------------------------------------------- - ! This subroutine is simply a wrapper that calls various FATES modules - ! that initialize global objects, things, constructs, etc. Globals only - ! need to be set once during initialization, for each machine, and this - ! should not be called for forked SMP processes. - ! -------------------------------------------------------------------------- - - logical,intent(in) :: is_master ! This is useful for reporting - ! and diagnostics so info is not printed - ! on numerous nodes to standard out. This - ! is not used to filter which machines - ! (nodes) to run these procedures, they - ! should be run on ALL nodes. - - ! Initialize PARTEH globals - ! (like the element lists, and mapping tables) - call InitPARTEHGlobals() - - ! Initialize Hydro globals - ! (like water retention functions) - call InitHydroGlobals() - - - return - end subroutine InitFatesGlobals - - ! ==================================================================================== - - - subroutine InitPARTEHGlobals() - - ! Initialize the Plant Allocation and Reactive Transport - ! global functions and mapping tables - ! Also associate the elements defined in PARTEH with a list in FATES - ! "element_list" is useful because it allows the fates side of the code - ! to loop through elements, and call the correct PARTEH interfaces - ! automatically. - - select case(hlm_parteh_mode) - case(prt_carbon_allom_hyp) - - num_elements = 1 - allocate(element_list(num_elements)) - element_list(1) = carbon12_element - element_pos(:) = 0 - element_pos(carbon12_element) = 1 - - call InitPRTGlobalAllometricCarbon() - - case(prt_cnp_flex_allom_hyp) - - num_elements = 3 - allocate(element_list(num_elements)) - element_list(1) = carbon12_element - element_list(2) = nitrogen_element - element_list(3) = phosphorus_element - element_pos(:) = 0 - element_pos(carbon12_element) = 1 - element_pos(nitrogen_element) = 2 - element_pos(phosphorus_element) = 3 - - !call InitPRTGlobalAllometricCNP() - write(fates_log(),*) 'You specified the allometric CNP mode' - write(fates_log(),*) 'with relaxed target stoichiometry.' - write(fates_log(),*) 'I.e., namelist parametre fates_parteh_mode = 2' - write(fates_log(),*) 'This mode is not available yet. Please set it to 1.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - case DEFAULT - write(fates_log(),*) 'You specified an unknown PRT module' - write(fates_log(),*) 'Check your setting for fates_parteh_mode' - write(fates_log(),*) 'in the CLM namelist. The only valid value now is 1' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end select - - end subroutine InitPARTEHGlobals - - - end module FatesInterfaceMod From 43d265cd100b426db8b499c3a96c1ae665b5da5e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 9 Jan 2020 14:57:38 -0800 Subject: [PATCH 044/114] Re-arranging code in preparation for 2D solver --- biogeophys/FatesPlantHydraulicsMod.F90 | 414 ++++++++++++++----------- main/FatesHydraulicsMemMod.F90 | 3 + 2 files changed, 230 insertions(+), 187 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index e565f72c1a..da75344499 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -62,7 +62,7 @@ module FatesPlantHydraulicsMod use FatesAllometryMod , only : set_root_fraction use FatesAllometryMod , only : i_hydro_rootprof_context - + use FatesHydraulicsMemMod, only: use_2d_hydrosolve use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type use FatesHydraulicsMemMod, only: n_hypool_plant @@ -2214,18 +2214,14 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: aroot_frac_plant ! The fraction of the total lenght of absorbing roots contained in one soil layer ! that are devoted to a single plant - ! hydraulics conductances - real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: psi_aroot ! matric potential in absorbing root [MPa] real(r8) :: ftc_aroot ! fraction of total conductance in absorbing root [-] real(r8) :: psi_shell ! matric potential of a given shell [-] real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] real(r8) :: kmax_up ! Kmax of upper rhizosphere compartments [kg s-1 Mpa-1] real(r8) :: kmax_lo ! Kamx of lower rhizosphere compartments [kg s-1 Mpa-1] - real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] - real(r8) :: r_bg ! total estimated resistance in below ground compartments - ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) + real(r8) :: wb_error ! Solve error for a single plant-layer [kg] real(r8) :: wb_error_site ! Error reflecting difference between site storage before and after ! integration, with the change in the uptake boundary condition @@ -2247,8 +2243,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! as defined by the input boundary condition real(r8) :: transp_col_check ! Column mean transpiration rate [mm H2O/m2] as defined ! by the sum of water fluxes through the cohorts - real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating - ! which kmax to use when forecasting uptake layer ordering [MPa] + real(r8) :: patch_wgt ! fraction of current patch relative to the whole site ! note that this is almost but not quite cpatch%area/AREA @@ -2429,187 +2424,47 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! |_____| | | k-1 | k | k+1 | !--------------------------------------------------------------------------- - ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, - ! each of which encompass all plant nodes and soil nodes for a given soil layer j, - ! with the timestep fraction for each layer-specific solution proportional to each - ! layer's contribution to the total root-soil conductance - ! Water potential in plant nodes is updated after each solution - ! As such, the order across soil layers in which the solution is conducted matters. - ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance - ! NET EFFECT: total water removed from plant-soil system remains the same: it - ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) - ! root water uptake in each layer is proportional to each layer's total - ! root length density and soil matric potential - ! root hydraulic redistribution emerges within this sequence when a - ! layers have transporting-to-absorbing root water potential gradients of opposite sign - - - kbg_tot = 0._r8 - do j=1,site_hydr%nlevsoi_hyd - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - - psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) - - - ! Note, since their is no elevation difference between - ! the absorbing root and its layer, no need to calc - ! diff in total, just matric is fine [MPa] - if(ccohort_hydr%psi_aroot(j) < psi_inner_shell) then - kmax_aroot = ccohort_hydr%kmax_aroot_radial_in(j) - else - kmax_aroot = ccohort_hydr%kmax_aroot_radial_out(j) - end if - - ! Get matric potential [Mpa] of the absorbing root - psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) - - ! Get Fraction of Total Conductivity [-] of the absorbing root - ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) - - ! Calculate total effective conductance over path [kg s-1 MPa-1] - ! from absorbing root node to 1st rhizosphere shell - r_bg = 1._r8/(kmax_aroot*ftc_aroot) - - ! Path is across the upper an lower rhizosphere comparment - ! on each side of the nodes. Since there is no flow across the outer - ! node to the edge, we ignore that last half compartment - aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - - do k = 1,nshell - - kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant - kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - - psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) - - ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) - - r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) - if(kccohort_hydr%iterh1) .and. (iter>1) )then - ccohort_hydr%iterlayer = real(j) - end if - - ! Save the number of times we refined our sub-step counts (iterh1) - ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) - ! Save the number of sub-steps we ultimately used - ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) - - ! Update water contents in the relevant plant compartments [m3/m3] + if(use_2d_hydrosolve) then - ! Leaf and above-ground stems - ccohort_hydr%th_ag(1:n_hypool_ag) = ccohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - ! Transporting root - ccohort_hydr%th_troot = ccohort_hydr%th_troot + dth_node(n_hypool_ag+1) - ! Absorbing root - ccohort_hydr%th_aroot(j) = ccohort_hydr%th_aroot(j) + dth_node(n_hypool_ag+2) - - - ! Change in water per plant [kg/plant] - dwat_veg_coh = & - (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o - - ! Accumulate site level diagnosti of plant water change - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV - - ! Update total site-level stored plant water - site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV + call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake,wb_error,iter,nsteps) - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_error - - ! Update total error in [kg/m2 ground] - ! (RGK: should this be + wb_error*ccohort%n/ccohort%c_area ??? - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area*AREA_INV - - - ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow - ccohort_hydr%rootuptake(j) = ccohort_hydr%rootuptake(j) + rootuptake - - ! Save the change in water mass in the rhizosphere. Note that we did - ! not immediately update the state variables upon completing each - ! plant-layer solve. We accumulate the difference, and apply them - ! after all cohort-layers are complete. This allows each cohort - ! to experience the same water conditions (for good or bad). - - if(site_hydr%l_aroot_layer(j) ccohort%shorter enddo !cohort @@ -2832,10 +2686,6 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! Get the cross-section of the plant's sapwood area [m2] call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) - - - - ! Leaf Maximum Hydraulic Conductance ! The starting hypothesis is that there is no resistance inside the ! leaf, between the petiole and the center of storage. To override @@ -3007,8 +2857,6 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer - - end do !write(fates_log(),*) 'ksu:',ccohort_hydr%kmax_stem_upper(:) @@ -3024,8 +2872,109 @@ end subroutine UpdatePlantKmax ! =================================================================================== + subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) + + ! Arguments (IN) + type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + + + ! Arguments (INOUT) + integer, intent(inout) :: ordered(:) + + ! Locals + + real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating + ! which kmax to use when forecasting uptake layer ordering [MPa] + real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] + real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] + real(r8) :: r_bg ! total estimated resistance in below ground compartments + ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] + real(r8) :: psi_shell ! matric potential of a given shell [-] + real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] + integer :: tmp ! temporarily holds a soil layer index + integer :: j,jj,k ! layer and shell indices + + + kbg_tot = 0._r8 + do j=1,site_hydr%nlevsoi_hyd + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. + + psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) + + ! Note, since their is no elevation difference between + ! the absorbing root and its layer, no need to calc + ! diff in total, just matric is fine [MPa] + if(ccohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = ccohort_hydr%kmax_aroot_radial_in(j) + else + kmax_aroot = ccohort_hydr%kmax_aroot_radial_out(j) + end if + + ! Get matric potential [Mpa] of the absorbing root + psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + + ! Get Fraction of Total Conductivity [-] of the absorbing root + ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + ! from absorbing root node to 1st rhizosphere shell + r_bg = 1._r8/(kmax_aroot*ftc_aroot) + + ! Path is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = 1,nshell + + kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant + + psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) + + ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) + + r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) + if(kccohort_hydr%iterh1) .and. (iter>1) )then + ccohort_hydr%iterlayer = real(j) + end if + + ! Save the number of times we refined our sub-step counts (iterh1) + ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) + ! Save the number of sub-steps we ultimately used + ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) + + ! Update water contents in the relevant plant compartments [m3/m3] + + ! Leaf and above-ground stems + ccohort_hydr%th_ag(1:n_hypool_ag) = ccohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + ! Transporting root + ccohort_hydr%th_troot = ccohort_hydr%th_troot + dth_node(n_hypool_ag+1) + ! Absorbing root + ccohort_hydr%th_aroot(j) = ccohort_hydr%th_aroot(j) + dth_node(n_hypool_ag+2) + + + ! Change in water per plant [kg/plant] + dwat_veg_coh = & + (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & + dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o + + ! Accumulate site level diagnosti of plant water change + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV + + ! Update total site-level stored plant water + site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV + + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_error + + ! Update total error in [kg/m2 ground] + ! (RGK: should this be + wb_error*ccohort%n/ccohort%c_area ??? + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area*AREA_INV + + + ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow + ccohort_hydr%rootuptake(j) = ccohort_hydr%rootuptake(j) + rootuptake + + ! Save the change in water mass in the rhizosphere. Note that we did + ! not immediately update the state variables upon completing each + ! plant-layer solve. We accumulate the difference, and apply them + ! after all cohort-layers are complete. This allows each cohort + ! to experience the same water conditions (for good or bad). + + if(site_hydr%l_aroot_layer(j) Date: Thu, 9 Jan 2020 16:15:40 -0800 Subject: [PATCH 045/114] Transfering in Yilins matrix code. --- biogeophys/FatesPlantHydraulicsMod.F90 | 638 +++++++++++++++++++++++++ main/FatesHydraulicsMemMod.F90 | 95 ++++ 2 files changed, 733 insertions(+) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index da75344499..17dc9150bb 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4277,6 +4277,644 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) end subroutine Hydraulics_Tridiagonal + subroutine boundary_hdiff_and_k_alt(ccohort_hydr,psi_node,flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) + ! + ! !ARGUMENTS + type(ed_cohort_hydr_type) :: ccohort_hydr + real(r8) :: psi_node(num_nodes) + real(r8) :: flc_node(num_nodes) + real(r8) :: dflcdpsi_node(num_nodes) + real(r8) , intent(out) :: hdiff_bound(num_connections) !total water potential difference across lower boundary [MPa] + real(r8) , intent(out) :: dhdpsi(num_connections,2) ! + real(r8) , intent(out) :: k_bound(num_connections) ! + real(r8) , intent(out) :: dkdpsi(num_connections,2) ! + real(r8) :: k_up,k_dn + integer :: icnx,id_dn,id_up + integer :: k_arootsoil + real(r8) :: k_bound_aroot_soil1 ! radial conductance ofabsorbing roots [kg s-1 MPa-1] + real(r8) :: k_bound_aroot_soil2 ! conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] +! + integer :: nstep + nstep = get_nstep() + associate( & + z_node => ccohort_hydr%z_node, & + conn_up => ccohort_hydr%conn_up, & + conn_dn => ccohort_hydr%conn_dn, & + cond_up => ccohort_hydr%cond_up, & + cond_dn => ccohort_hydr%cond_dn, & + conductance => ccohort_hydr%conductance & + ) + k_arootsoil = n_hypool_tot-nshell + do icnx = 1, num_connections + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + hdiff_bound(icnx) = 1.e-6_r8*denh2o*grav*(z_node(id_dn) - z_node(id_up)) + (psi_node(id_dn) - psi_node(id_up)) + dhdpsi(icnx,1) = 1.d0 ! for id_dn + dhdpsi(icnx,2) = -1.d0 ! for id_up + do_kbound_upstream = .true. + if(do_kbound_upstream) then + if(icnx == (k_arootsoil)) then ! absorbing root-1st rhizosphere shell boundary. Comprised of two distinct conductance terms each with distinct water potentials + k_dn = cond_dn(icnx) * flc_node(id_dn) + k_up = cond_up(icnx) * flc_node(id_up) + k_bound(icnx) = 1._r8/(1._r8/k_dn + 1._r8/k_up) + dkdpsi(icnx,1) = ((k_bound(icnx)/k_dn)**2._r8) * cond_dn(icnx)*dflcdpsi_node(id_dn) + dkdpsi(icnx,2) = ((k_bound(icnx)/k_up)**2._r8) * cond_up(icnx)*dflcdpsi_node(id_up) + else + ! examine direction of water flow; use the upstream node's k for + ! the boundary k. (as suggested by Ethan Coon, LANL) + if(hdiff_bound(icnx) < 0._r8) then + k_bound(icnx) = conductance(icnx) * flc_node(id_up) !water moving towards atmosphere + dkdpsi(icnx,1) = 0._r8 + dkdpsi(icnx,2) = conductance(icnx) * dflcdpsi_node(id_up) + else + k_bound(icnx) = conductance(icnx) * flc_node(id_dn) !water moving towards soil + dkdpsi(icnx,1) = conductance(icnx) * dflcdpsi_node(id_dn) + dkdpsi(icnx,2) = 0._r8 + end if + end if + else + k_dn = cond_dn(icnx) * flc_node(id_dn) + k_up = cond_up(icnx) * flc_node(id_up) + k_bound(icnx) = 1._r8/(1._r8/k_dn + 1._r8/k_up) + dkdpsi(icnx,1) = ((k_bound(icnx)/k_dn)**2._r8) * cond_dn(icnx) * dflcdpsi_node(id_dn) + dkdpsi(icnx,2) = ((k_bound(icnx)/k_up)**2._r8) * cond_up(icnx) * dflcdpsi_node(id_up) + end if +! update location + if(icnx == k_arootsoil) & + k_arootsoil = k_arootsoil + nshell + 1 + enddo + end associate + + return +! + end subroutine boundary_hdiff_and_k_alt + + + !------------------------------------------------------------------------------ + subroutine Hydraulics_alt_1DSolve(dtime, s, cc_p,ft, qtop, site_hydr,ccohort_hydr,bc_in,dth_layershell,sapflow) +! + use LUsolveMod +! use petscvec +! use petscmat +! use petscsys + use clm_time_manager , only : get_nstep + use EDTypesMod , only : AREA + + ! ARGUMENTS: +!#include + ! ----------------------------------------------------------------------------------- + type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure + type(ed_cohort_hydr_type), target :: ccohort_hydr + type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer + type(bc_in_type),intent(in) :: bc_in + integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol + integer :: j, icnx, pmx,inewt + integer :: id_dn, id_up + real(r8) :: psisat,B,thsat,psi_pt,tmp + real(r8) :: values(4) + real(r8) :: residual(num_nodes) + real(r8) :: ajac(num_nodes,num_nodes) + real(r8) :: dth_node(num_nodes) + real(r8) :: th_node_init(num_nodes) + real(r8) :: psi_node_init(num_nodes) + real(r8) :: th_node(num_nodes) + real(r8) :: psi_node(num_nodes) + real(r8) :: k_bound(num_connections) + real(r8) :: hdiff_bound(num_connections) + real(r8) :: hdiffx, k_boundx, dkdpsix + real(r8) :: dhdpsi(num_connections,2) + real(r8) :: dkdpsi(num_connections,2) + real(r8) :: dt_time + real(r8) :: dnr, thx, thx_pt + real(r8) :: qflx + real(r8) :: q_flux(num_connections) + real(r8) :: qtop, dqflx_dn, dqflx_up !qtop - flux from canopy, kgh2o indiv-1 s-1 + real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] + real(r8) :: dflcgsdth ! derivative of stomatal vuln curve wrt to leaf water content [m-3 m3] + real(r8) :: dqtopdflcgs ! derivative of cohort-level transpiration wrt btran [kgh2o indiv-1 s-1] + real(r8) :: dqtopdth_leaf ! derivative of transpiration rate wrt to leaf water content [kgh2o indiv-1 s-1 m-3 m-3] + + real(r8) :: qscale + integer :: s + integer :: num_nds + real(r8) :: blu(num_nodes) + real(r8) :: blux(num_nodes) + integer :: indices(num_nodes) + real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] + real(r8) :: flc_min_node( n_hypool_tot-nshell) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics)[-] + real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] + real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] + real(r8) :: dflcdpsi_node(num_nodes) ! derivative of fractional loss of conductivity wrt psi [MPa-1] + real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] + real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] + real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] + +! real(r8) :: th_node_init( npool_tot) ! initial volumetric water in water storage compartments [m3 m-3] + real(r8) :: hdiff_bound_1l( nshell+1) ! + real(r8) :: dth_layershell(nlevsoi_hyd_max,nshell) ! accumulated water content change over a cohort in a column [m3 m-3] +! real(r8) :: kmax_bound( npool_tot) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] +! real(r8) :: kmax_upper( npool_tot) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] +! real(r8) :: kmax_lower( npool_tot) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] + + integer :: icnv + real(r8) :: thsatx + real(r8) :: slx + real(r8) :: plx + real(r8) :: dplx + real(r8) :: rsd, rsdx, rlfx, rlfx1, rsdp + real(r8) :: acp + real(r8) :: dcomp + real(r8) :: dtime, dtx, dtcf, tm, dto, dtimex, var, varx, tmx,dtime_o + real(r8) :: dwat_veg_coh + integer :: nsd + integer :: niter + integer :: ntsr + integer :: n_hypool_at + integer :: ksh + integer :: outer_nodes(10) + integer :: bc_cnx(10) + real(r8) :: smp, h2osoi_liqvol + real(r8) :: e0(num_nodes) + real(r8) :: psiw(num_nodes) + real(r8) :: e1(num_nodes) + real(r8) :: e2(num_nodes) + real(r8) :: sapflow + integer :: ipiv(num_nodes) + integer :: info + integer :: itshk + type(ed_cohort_type),pointer :: ccohort ! current cohort +! PetscErrorCode :: ierr + integer :: nstep !number of time steps +! + !for debug only + nstep = get_nstep() + + if(nstep >= 669) then + print *,'nstep =',nstep + end if + ccohort => cc_p + associate( & + z_lower_ag => ccohort_hydr%z_lower_ag, & + z_upper_ag => ccohort_hydr%z_upper_ag, & + z_node_ag => ccohort_hydr%z_node_ag, & + z_node => ccohort_hydr%z_node, & + v_node => ccohort_hydr%v_node, & + conn_up => ccohort_hydr%conn_up, & + conn_dn => ccohort_hydr%conn_dn, & + cond_up => ccohort_hydr%cond_up, & + cond_dn => ccohort_hydr%cond_dn, & + conductance => ccohort_hydr%conductance, & + th_node_init => ccohort_hydr%th_node_init, & + th_node => ccohort_hydr%th_node, & + psi_node_init => ccohort_hydr%psi_node_init, & + psi_node => ccohort_hydr%psi_node, & + pm_type => ccohort_hydr%pm_type & + ) +! assign variables + th_node( 1 : n_hypool_ag ) =ccohort_hydr%th_ag(:) + th_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%th_troot(:) + flc_min_node( 1 : n_hypool_ag ) =ccohort_hydr%flc_min_ag(:) + flc_min_node((n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%flc_min_troot(:) + + + do k = 1, n_hypool_ag+n_hypool_troot + call psi_from_th(ft, porous_media(k), th_node(k), psi_node(k),site_hydr, bc_in) + call dpsidth_from_th(ft, porous_media(k), th_node(k),dpsidth_node(k), site_hydr, bc_in) + call flc_from_psi(ft, porous_media(k), psi_node(k), flc_node(k),site_hydr, bc_in) + call dflcdpsi_from_psi(ft, porous_media(k), psi_node(k),dflcdpsi_node(k), site_hydr, bc_in) + + if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then + if(flc_node(k) > flc_min_node(k)) then + dflcdpsi_node(k) = 0._r8 + flc_node(k) = flc_min_node(k) + end if + end if + enddo +! call dflcgsdpsi_from_psi(ccohort_hydr%psi_ag(1),ft, dflcgsdpsi) +! dflcgsdth = dflcgsdpsi * dpsidth_node(1) +! dqtopdflcgs = 0.1411985_r8 !BOC... estimated by trial-and-error:this term multiplied by the maximum value of dflcgsdth gives 150. + !NEEDED: an estimate for dqtopdflcgs + !that accounts for variable potential + !evapotranspiration (efpot). + + + +! psi_node(1:npool_bg) = psi_node_1l(1:npool_bg) +! th_node(1:npool_bg) = th_node_1l(1:npool_bg) + num_nds = n_hypool_ag + n_hypool_troot + + do j = 1,site_hydr%nlevsoi_hyd + th_node_1l((n_hypool_ag+n_hypool_troot+1)) = ccohort_hydr%th_aroot(j) + th_node_1l((n_hypool_ag+n_hypool_troot+2):(n_hypool_tot)) = site_hydr%h2osoi_liqvol_shell(j,:) + + do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot + num_nds = num_nds + 1 + call psi_from_th(ft, pm_type(num_nds), th_node_1l(k),psi_node_1l(k),site_hydr, bc_in) + call flc_from_psi(ft, pm_type(num_nds),psi_node_1l(k), flc_node_1l(k), site_hydr, bc_in) + call dflcdpsi_from_psi(ft, pm_type(num_nds),psi_node_1l(k), dflcdpsi_node_1l(k), site_hydr, bc_in) + + if(k == n_hypool_ag + n_hypool_troot + 1) then + if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then + if(flc_node_1l(k) > ccohort_hydr%flc_min_aroot(j)) then + dflcdpsi_node_1l(num_nds) = 0._r8 + flc_node_1l(num_nds) = ccohort_hydr%flc_min_aroot(j) + end if + end if + flc_node(num_nds) = flc_node_1l(k) + dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) + else + flc_node(num_nds) = flc_node_1l(k) + dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) + if(k==n_hypool_tot) outer_nodes(j) = num_nds + endif + psi_node(num_nds) = psi_node_1l(k) + th_node(num_nds) = th_node_1l(k) + enddo + +! h2osoi_liqvol = min(bc_in%eff_porosity_sl(j), & +! bc_in%h2o_liq_sisl(j)/(bc_in%dz_sisl(j)*denh2o)) +! call swcCampbell_psi_from_th(h2osoi_liqvol, & +! bc_in%watsat_sisl(j), (-1.0_r8)*bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, bc_in%bsw_sisl(j), smp) + enddo + th_node_init(:) = th_node(:) + psi_node_init(:) = psi_node(:) +! + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot +! + rlfx = 1._r8 + rlfx1 = 0.15_r8 + rsdp = 0._r8 + inewt = 0 + tmx = dtime + dtime_o = dtime + tm = 0 + ntsr = 0 + dth_layershell(:,:) = 0._r8 + do while(tm < tmx) + rlfx = 0.6_r8 + !rlfx1 = 0.15_r8 + rlfx1 = 0.1_r8 + rsdp = 0._r8 + inewt = 0 + 100 continue + tm = tm + dtime + niter = 0 + itshk = 0 + e0(:) = 0 + e1(:) = 0 + e2(:) = 0 + 200 continue + niter = niter + 1 +!zero matrix and residual + if(inewt == 0) then + ajac(:,:) = 0._r8 + endif + residual(:) = 0._r8 + blu(:) = 0._r8 +! + do k = 1, num_nodes + call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) + call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) + enddo + + call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) + + do k=1,num_nodes +! + residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) +! matrix + ic(:) = 0 + ir(:) = 0 + values(:) = 0._r8 + nc = 1 + nr = 1 + icol = k + ic(1) = icol + ir(1) = icol +! dnr = -1.e-6_r8 +! dnr = -0.005*abs(psi_node(k)) - 1e-12 + dnr = -1.e-8_r8 +! dnr = -max(1.e-6,0.05*abs(psi_node(k))) + if(pm_type(k) <= nt_ab) then + call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) +! incremented psi + psi_pt = psi_node(k) + dnr + call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) + values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr + else + j = pm_type(k)-nt_ab + B = bc_in%bsw_sisl(j) + psisat = bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8 !! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa + thsat = bc_in%watsat_sisl(j) + psi_pt = psi_node(k) + if( psi_pt >= -psisat ) then + tmp = 0._r8 + else + tmp = 1._r8/B*(-psi_pt/psisat)**(-1._r8-1._r8/B)/psisat + endif + values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp + endif + if(inewt == 0) then +! call MatSetValues( fmat,nr,ir(1),nc,ic(1),values(1),ADD_VALUES,ierr ) + ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) + end if + enddo + +! calculate boundary fluxes + nr = 2 + nc = 2 + do icnx=1,num_connections + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + ir(:) = 0 + ic(:) = 0 + values(:) = 0._r8 + qflx = -1._r8 * k_bound(icnx) * hdiff_bound(icnx) + if(icnx==2) sapflow =qflx + q_flux(icnx) = qflx + residual(id_dn) = residual(id_dn) - qflx + residual(id_up) = residual(id_up) + qflx + dqflx_dn = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,1) + k_bound(icnx)*dhdpsi(icnx,1)) + dqflx_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) + ir(1) = id_dn + ir(2) = id_up + ic(1) = id_dn + ic(2) = id_up + values(1) = -dqflx_dn + values(2) = -dqflx_up + values(3) = dqflx_dn + values(4) = dqflx_up + if(inewt == 0) then +! call MatSetValues( fmat,nr,ir,nc,ic,values,ADD_VALUES,ierr ) + ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) + ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) + end if + enddo +! + residual(1) = residual(1) + qtop +! call dflcgsdpsi_from_psi(psi_node(1),ft, dflcgsdpsi) +! dflcgsdth = dflcgsdpsi +! dqtopdflcgs = 0.1411985_r8 !BOC... estimated by trial-and-error:this term multiplied by the maximum value of dflcgsdth gives 150. + !NEEDED: an estimate for dqtopdflcgs + !that accounts for variable potential + !evapotranspiration (efpot). + + ! SET THE DQTOPDTH_LEAF TERM +! if(do_dqtopdth_leaf) then +! dqtopdth_leaf = dqtopdflcgs * dflcgsdth +! if(mono_decr_Rn .and. ccohort_hydr%psi_ag(1) >= -0.88_r8) then +! dqtopdth_leaf = 0._r8 +! else if(ccohort_hydr%psi_ag(1) < -0.88_r8) then +! dqtopdth_leaf = 150._r8 +! else +! dqtopdth_leaf = 0._r8 +! end if +! else +! dqtopdth_leaf = 0._r8 +! end if +! nr = 1 +! nc = 1 +! ir(1) = 0 +! ic(1) = 0 +! call MatSetValues( fmat,nr,ir,nc,ic,dqtopdth_leaf,ADD_VALUES,ierr ) + + residual(:) = -residual(:) +! call petsc_put_rhs(residual, frhs_vec) +! + icnv = 3 +! call petsc_solve(fksp,fmat,frhs_vec,fsol_vec) +! call petsc_get_solution(blu,fsol_vec) + !call ludcmp(ajac,num_nodes,indices,dcomp) + !call lubksb(ajac,num_nodes,indices,residual) + !CALL DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +! check residual +!if(nstep==15764) print *,'ft,it,rsd-',ft,niter,rsd,'qtop',qtop,psi_node,'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node + rsd = 0._r8 + nsd = 0 + do k = 1, num_nodes + rsdx = abs(residual(k)) +! check NaNs + if( rsdx /= rsdx ) then + icnv = 1 + exit + endif + if( rsdx > rsd ) then + rsd = rsdx + nsd = k + endif + enddo +! matrix no update if inewt = 1 +! if( niter > 100 .and. rsd < 1.e-1) inewt = 1 + if(icnv == 1) goto 199 + rsdp = rsd +! check convergence + if( rsd > 1.e-8_r8 ) then + icnv = 2 + !endif + call ludcmp(ajac,num_nodes,indices,dcomp) + call lubksb(ajac,num_nodes,indices,residual) + + info = 0 +! call dgelg(residual,ajac,num_nodes,num_nodes,1.e-14_r8,info) + !call dgesv(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) + + if ( info == -1 ) then + write(fates_log(),*) 'singular matrix in dgesv' !There is a row of zeros. + call endrun(msg=errMsg(sourcefile, __LINE__)) + END IF + blu(:) = residual(:) + +! update pressure +! limit pressure change + do k = 1, num_nodes + if(pm_type(k) >= 4) then +! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx1 +!if(abs(blu(k))> abs(psi_node(k))) then +! psi_node(k) = psi_node(k) + blu(k)*rlfx1*0.5 +!else + psi_node(k) = psi_node(k) + blu(k)*rlfx1 +!endif + + else +! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx + psi_node(k) = psi_node(k) + blu(k) * rlfx + endif + + enddo + endif + if( icnv == 2 .and. niter > 200) then + icnv = 1 + endif + if(niter > 500) then + rlfx = 0.4_r8 + rlfx1 = 0.1_r8 + end if +199 continue + if( icnv == 1 ) then + write(*,'(10x,a)') '--- Convergence Failure ---' + write(*,'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & + rsd,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) + if( ntsr < 10 ) then + tm = tm - dtime + ntsr = ntsr + 1 + dtx = dtime + dtcf = 0.2_r8 + dtimex = dtime * dtcf + dtime = min(dtimex,tmx-tm) + dto = dtime + var = dtime + varx = dtx + write(*,'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & + 'Time Step Reduced From ',varx,'s',' to ', & + var,'s' + do k = 1,num_nodes + psi_node(k) = psi_node_init(k) + th_node(k) = th_node_init(k) + enddo + rlfx = 0.6_r8 + rlfx1 = 0.15_r8 +! +!--- Number of time step reductions failure: stop simulation --- +! + else + write(*,'(10x,a)') '--- Time Step Reduction Limit Exceeded---' + icnv = 4 + endif + endif + do k=1,num_nodes + call th_from_psi(ft,pm_type(k),psi_node(k),th_node(k),site_hydr,bc_in) + enddo + if(icnv == 1) then + goto 100 + elseif(icnv == 2) then + goto 200 + elseif(icnv == 3) then + dth_node(:) = th_node(:) - th_node_init(:) + goto 201 + else + stop + endif +! enddo + 201 continue + + ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) + ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) + ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) + ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%psi_troot(1:n_hypool_troot) = psi_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) + num_nds = n_hypool_ag+n_hypool_troot + n_hypool_at = n_hypool_ag + n_hypool_troot + 1 + do j = 1,site_hydr%nlevsoi_hyd + do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot + num_nds = num_nds + 1 + if(k==n_hypool_at) then + ccohort_hydr%th_aroot(j) = th_node(num_nds) + ccohort_hydr%psi_aroot(j) = psi_node(num_nds) + ccohort_hydr%flc_aroot(j) = flc_node(num_nds) + dwat_veg_coh = dwat_veg_coh + dth_node(num_nds) * v_node(num_nds) + else + ksh = k-n_hypool_at + dth_layershell(j,ksh) = dth_layershell(j,ksh) + & + (th_node(num_nds) - th_node_init(num_nds)) * & + ccohort_hydr%l_aroot_layer(j) * & + ccohort%n /site_hydr%l_aroot_layer(j) * dtime + endif + enddo + enddo + dwat_veg_coh = dwat_veg_coh * denh2o + site_hydr%dwat_veg = site_hydr%dwat_veg+ dwat_veg_coh*ccohort%n/AREA!*patch_wgt + site_hydr%h2oveg = site_hydr%h2oveg +dwat_veg_coh*ccohort%n/AREA!*patch_wgt + th_node_init(:) = th_node(:) + psi_node_init(:) = psi_node(:) + enddo + dth_layershell(:,:) = dth_layershell(:,:) / dtime_o + end associate + + return + end subroutine hydraulics_alt_1DSolve + + ! ===================================================================================== + subroutine initHydrSolver(sites,bc_in) + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) + + ! Local + type(ed_site_hydr_type), pointer :: site_hydr + integer :: nsites + integer :: nlevsoil ! Number of soil layers + integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers + integer :: num_cnxs + integer :: num_nds + integer :: num_connections + integer :: node_tr_end + integer :: nt_ab + integer :: j, k, s + integer, dimension(:),allocatable :: conn_dn + integer, dimension(:),allocatable :: conn_up +! + if(hlm_use_alt_planthydro.eq.ifalse) return + ! number of connections between organs, root/shell +! + nsites = ubound(sites,1) + + do s = 1,nsites + site_hydr => sites(s)%si_hydr + + nlevsoil = bc_in(s)%nlevsoil + nlevsoil_hyd = site_hydr%nlevsoi_hyd + num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + + (n_hypool_aroot + nshell) * nlevsoil_hyd + allocate(conn_dn(num_connections)) + allocate(conn_up(num_connections)) + + conn_dn = 0 + conn_up = 0 +! + num_cnxs = 0 + do k = 1, n_hypool_leaf + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom + conn_up(num_cnxs) = k + 1 + enddo + do k = n_hypool_leaf+1, n_hypool_ag + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k + conn_up(num_cnxs) = k+1 + enddo + + num_nds = n_hypool_ag+n_hypool_troot + node_tr_end = num_nds + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot + num_cnxs = n_hypool_ag + do j = 1,nlevsoil_hyd + + do k = 1, n_hypool_aroot + nshell + num_nds = num_nds + 1 + num_cnxs = num_cnxs + 1 + if( k == 1 ) then !troot-aroot + !junction node + conn_dn(num_cnxs) = node_tr_end !absorbing root + conn_up(num_cnxs) = num_nds + + else + conn_dn(num_cnxs) = num_nds - 1 + conn_up(num_cnxs) = num_nds + endif + enddo +! + enddo ! end soil layer +! call petsc_solver_init(fksp,fmat,frhs_vec,fsol_vec, & +! conn_dn, conn_up) + + deallocate(conn_dn) + deallocate(conn_up) + end do +! + end subroutine initHydrSolver + + subroutine InitHydroGlobals() diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 8f515cd3fe..eedb0e9342 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -374,6 +374,101 @@ subroutine InitHydrSite(this) return end subroutine InitHydrSite +! ===================================================================================== + subroutine SetPhsOrganConnection(this) +! + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer :: k ! local indexing + integer :: num_cnxs + integer :: num_nds + integer :: nt_ab + integer :: s, c, pi, p_t + class(ed_cohort_hydr_type),intent(inout) :: this + !---------------------------------------------------------------------- + + associate( & + conn_up => this%conn_up, & + conn_dn => this%conn_dn, & + pm_type => this%pm_type & + ) +! + pm_type(:) = 0 + num_nds = 0 + num_cnxs = 0 + do k = 1, n_hypool_leaf + pm_type(k) = k + num_nds = num_nds + 1 + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom + conn_up(num_cnxs) = k + 1 + enddo + do k = n_hypool_leaf+1, n_hypool_ag + pm_type(k) = k + num_nds = num_nds + 1 + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k + conn_up(num_cnxs) = k+1 + enddo + do k=n_hypool_ag+1, n_hypool_ag+n_hypool_troot + pm_type(k) = k + num_nds = num_nds + 1 + enddo + end associate +! + end subroutine SetPhsOrganConnection + ! ===================================================================================== + subroutine SetPhsSoilConnection(this) +! + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer :: j,k ! local indexing + integer :: num_cnxs + integer :: num_cnx + integer :: num_nds + integer :: nt_ab + integer :: node_tr_end + class(ed_cohort_hydr_type),intent(inout) :: this + ! lower - towards the soil (k relate to _dn), upper - towards the atmosphere + ! (k+1 to _up) + ! + !---------------------------------------------------------------------- + associate( & + conn_up => this%conn_up, & + conn_dn => this%conn_dn, & + pm_type => this%pm_type, & + nlevsoil_hyd => this%nlevsoi_hyd & + ) + num_nds = n_hypool_ag+n_hypool_troot + node_tr_end = num_nds + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot + num_cnxs = n_hypool_ag + do j = 1,nlevsoil_hyd + do k = 1, n_hypool_aroot + nshell + num_nds = num_nds + 1 + if(k <=n_hypool_aroot) then + pm_type(num_nds) = n_hypool_ag+n_hypool_troot+k + else + pm_type(num_nds) = nt_ab+j + endif + num_cnxs = num_cnxs + 1 + if( k == 1 ) then !troot-aroot + !junction node + conn_dn(num_cnxs) = node_tr_end !absorbing root + conn_up(num_cnxs) = num_nds + else + conn_dn(num_cnxs) = num_nds - 1 + conn_up(num_cnxs) = num_nds + endif + enddo +! + enddo ! end soil layer + end associate + end subroutine SetPhsSoilConnection + + ! =================================================================================== + + From 5d48850591fe70240e366c07a2419f11c8b1ad50 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 10 Jan 2020 11:06:38 -0800 Subject: [PATCH 046/114] fates-hydro refactors, meshing in matrix solve --- biogeophys/FatesPlantHydraulicsMod.F90 | 913 +++++++++++-------------- main/FatesHydraulicsMemMod.F90 | 68 +- 2 files changed, 455 insertions(+), 526 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 17dc9150bb..c476fc0031 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4276,7 +4276,8 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) end subroutine Hydraulics_Tridiagonal - + ! ===================================================================================== + subroutine boundary_hdiff_and_k_alt(ccohort_hydr,psi_node,flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) ! ! !ARGUMENTS @@ -4349,255 +4350,227 @@ subroutine boundary_hdiff_and_k_alt(ccohort_hydr,psi_node,flc_node,dflcdpsi_node ! end subroutine boundary_hdiff_and_k_alt + ! ===================================================================================== - !------------------------------------------------------------------------------ - subroutine Hydraulics_alt_1DSolve(dtime, s, cc_p,ft, qtop, site_hydr,ccohort_hydr,bc_in,dth_layershell,sapflow) -! - use LUsolveMod -! use petscvec -! use petscmat -! use petscsys - use clm_time_manager , only : get_nstep - use EDTypesMod , only : AREA - - ! ARGUMENTS: -!#include - ! ----------------------------------------------------------------------------------- + subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_hydr, & + bc_in,dth_layershell,sapflow) + + use EDTypesMod , only : AREA + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(ed_cohort_hydr_type), target :: ccohort_hydr - type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer - type(bc_in_type),intent(in) :: bc_in - integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol - integer :: j, icnx, pmx,inewt - integer :: id_dn, id_up - real(r8) :: psisat,B,thsat,psi_pt,tmp - real(r8) :: values(4) - real(r8) :: residual(num_nodes) - real(r8) :: ajac(num_nodes,num_nodes) - real(r8) :: dth_node(num_nodes) - real(r8) :: th_node_init(num_nodes) - real(r8) :: psi_node_init(num_nodes) - real(r8) :: th_node(num_nodes) - real(r8) :: psi_node(num_nodes) - real(r8) :: k_bound(num_connections) - real(r8) :: hdiff_bound(num_connections) - real(r8) :: hdiffx, k_boundx, dkdpsix - real(r8) :: dhdpsi(num_connections,2) - real(r8) :: dkdpsi(num_connections,2) - real(r8) :: dt_time - real(r8) :: dnr, thx, thx_pt - real(r8) :: qflx - real(r8) :: q_flux(num_connections) - real(r8) :: qtop, dqflx_dn, dqflx_up !qtop - flux from canopy, kgh2o indiv-1 s-1 - real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] + type(ed_cohort_hydr_type), target :: ccohort_hydr + type(ed_cohort_type) , intent(inout), target :: cohort + type(bc_in_type),intent(in) :: bc_in + integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol + integer :: j, icnx, pmx,inewt + integer :: id_dn, id_up + real(r8) :: psisat,B,thsat,psi_pt,tmp + real(r8) :: values(4) + real(r8) :: residual(num_nodes) + real(r8) :: ajac(num_nodes,num_nodes) + real(r8) :: dth_node(num_nodes) + real(r8) :: th_node_init(num_nodes) + real(r8) :: psi_node_init(num_nodes) + real(r8) :: th_node(num_nodes) + real(r8) :: psi_node(num_nodes) + real(r8) :: k_bound(num_connections) + real(r8) :: hdiff_bound(num_connections) + real(r8) :: hdiffx, k_boundx, dkdpsix + real(r8) :: dhdpsi(num_connections,2) + real(r8) :: dkdpsi(num_connections,2) + real(r8) :: dt_time + real(r8) :: dnr, thx, thx_pt + real(r8) :: qflx + real(r8) :: q_flux(num_connections) + real(r8) :: qtop, dqflx_dn, dqflx_up !qtop - flux from canopy, kgh2o indiv-1 s-1 + real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] real(r8) :: dflcgsdth ! derivative of stomatal vuln curve wrt to leaf water content [m-3 m3] real(r8) :: dqtopdflcgs ! derivative of cohort-level transpiration wrt btran [kgh2o indiv-1 s-1] real(r8) :: dqtopdth_leaf ! derivative of transpiration rate wrt to leaf water content [kgh2o indiv-1 s-1 m-3 m-3] - - real(r8) :: qscale - integer :: s - integer :: num_nds - real(r8) :: blu(num_nodes) - real(r8) :: blux(num_nodes) - integer :: indices(num_nodes) - real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: flc_min_node( n_hypool_tot-nshell) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics)[-] - real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] - real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] - real(r8) :: dflcdpsi_node(num_nodes) ! derivative of fractional loss of conductivity wrt psi [MPa-1] - real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] - real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] - real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] - -! real(r8) :: th_node_init( npool_tot) ! initial volumetric water in water storage compartments [m3 m-3] - real(r8) :: hdiff_bound_1l( nshell+1) ! - real(r8) :: dth_layershell(nlevsoi_hyd_max,nshell) ! accumulated water content change over a cohort in a column [m3 m-3] -! real(r8) :: kmax_bound( npool_tot) ! lower boundary maximum hydraulic conductance of compartments [kg s-1 MPa-1] -! real(r8) :: kmax_upper( npool_tot) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] -! real(r8) :: kmax_lower( npool_tot) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] - - integer :: icnv - real(r8) :: thsatx - real(r8) :: slx - real(r8) :: plx - real(r8) :: dplx - real(r8) :: rsd, rsdx, rlfx, rlfx1, rsdp - real(r8) :: acp - real(r8) :: dcomp - real(r8) :: dtime, dtx, dtcf, tm, dto, dtimex, var, varx, tmx,dtime_o - real(r8) :: dwat_veg_coh - integer :: nsd - integer :: niter - integer :: ntsr - integer :: n_hypool_at - integer :: ksh - integer :: outer_nodes(10) - integer :: bc_cnx(10) - real(r8) :: smp, h2osoi_liqvol - real(r8) :: e0(num_nodes) - real(r8) :: psiw(num_nodes) - real(r8) :: e1(num_nodes) - real(r8) :: e2(num_nodes) - real(r8) :: sapflow - integer :: ipiv(num_nodes) - integer :: info - integer :: itshk - type(ed_cohort_type),pointer :: ccohort ! current cohort -! PetscErrorCode :: ierr - integer :: nstep !number of time steps -! - !for debug only - nstep = get_nstep() - if(nstep >= 669) then - print *,'nstep =',nstep - end if - ccohort => cc_p - associate( & - z_lower_ag => ccohort_hydr%z_lower_ag, & - z_upper_ag => ccohort_hydr%z_upper_ag, & - z_node_ag => ccohort_hydr%z_node_ag, & - z_node => ccohort_hydr%z_node, & - v_node => ccohort_hydr%v_node, & - conn_up => ccohort_hydr%conn_up, & - conn_dn => ccohort_hydr%conn_dn, & - cond_up => ccohort_hydr%cond_up, & - cond_dn => ccohort_hydr%cond_dn, & - conductance => ccohort_hydr%conductance, & - th_node_init => ccohort_hydr%th_node_init, & - th_node => ccohort_hydr%th_node, & - psi_node_init => ccohort_hydr%psi_node_init, & - psi_node => ccohort_hydr%psi_node, & - pm_type => ccohort_hydr%pm_type & - ) -! assign variables - th_node( 1 : n_hypool_ag ) =ccohort_hydr%th_ag(:) - th_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%th_troot(:) - flc_min_node( 1 : n_hypool_ag ) =ccohort_hydr%flc_min_ag(:) - flc_min_node((n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%flc_min_troot(:) + real(r8) :: qscale + integer :: s + integer :: num_nds + real(r8) :: blu(num_nodes) + real(r8) :: blux(num_nodes) + integer :: indices(num_nodes) + real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] + real(r8) :: flc_min_node( n_hypool_tot-nshell) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics)[-] + real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] + real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] + real(r8) :: dflcdpsi_node(num_nodes) ! derivative of fractional loss of conductivity wrt psi [MPa-1] + real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] + real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] + real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] + + real(r8) :: hdiff_bound_1l( nshell+1) ! + real(r8) :: dth_layershell(nlevsoi_hyd_max,nshell) ! accumulated water content change over a cohort in a column [m3 m-3] + integer :: icnv + real(r8) :: thsatx + real(r8) :: slx + real(r8) :: plx + real(r8) :: dplx + real(r8) :: rsd, rsdx, rlfx, rlfx1, rsdp + real(r8) :: acp + real(r8) :: dcomp + real(r8) :: dtime, dtx, dtcf, tm, dto, dtimex, var, varx, tmx,dtime_o + real(r8) :: dwat_veg_coh + integer :: nsd + integer :: niter + integer :: ntsr + integer :: n_hypool_at + integer :: ksh + integer :: outer_nodes(10) + integer :: bc_cnx(10) + real(r8) :: smp, h2osoi_liqvol + real(r8) :: e0(num_nodes) + real(r8) :: psiw(num_nodes) + real(r8) :: e1(num_nodes) + real(r8) :: e2(num_nodes) + real(r8) :: sapflow + integer :: ipiv(num_nodes) + integer :: info + integer :: itshk + integer :: nstep !number of time steps + ! + !for debug only + nstep = get_nstep() - - do k = 1, n_hypool_ag+n_hypool_troot - call psi_from_th(ft, porous_media(k), th_node(k), psi_node(k),site_hydr, bc_in) - call dpsidth_from_th(ft, porous_media(k), th_node(k),dpsidth_node(k), site_hydr, bc_in) - call flc_from_psi(ft, porous_media(k), psi_node(k), flc_node(k),site_hydr, bc_in) - call dflcdpsi_from_psi(ft, porous_media(k), psi_node(k),dflcdpsi_node(k), site_hydr, bc_in) - - if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then - if(flc_node(k) > flc_min_node(k)) then - dflcdpsi_node(k) = 0._r8 - flc_node(k) = flc_min_node(k) - end if - end if - enddo -! call dflcgsdpsi_from_psi(ccohort_hydr%psi_ag(1),ft, dflcgsdpsi) -! dflcgsdth = dflcgsdpsi * dpsidth_node(1) -! dqtopdflcgs = 0.1411985_r8 !BOC... estimated by trial-and-error:this term multiplied by the maximum value of dflcgsdth gives 150. - !NEEDED: an estimate for dqtopdflcgs - !that accounts for variable potential - !evapotranspiration (efpot). - + + associate( & + z_lower_ag => ccohort_hydr%z_lower_ag, & + z_upper_ag => ccohort_hydr%z_upper_ag, & + z_node_ag => ccohort_hydr%z_node_ag, & + z_node => ccohort_hydr%z_node, & + v_node => ccohort_hydr%v_node, & + conn_up => ccohort_hydr%conn_up, & + conn_dn => ccohort_hydr%conn_dn, & + cond_up => ccohort_hydr%cond_up, & + cond_dn => ccohort_hydr%cond_dn, & + conductance => ccohort_hydr%conductance, & + th_node_init => ccohort_hydr%th_node_init, & + th_node => ccohort_hydr%th_node, & + psi_node_init => ccohort_hydr%psi_node_init, & + psi_node => ccohort_hydr%psi_node, & + pm_type => ccohort_hydr%pm_type & + ) + + ! assign variables + th_node( 1 : n_hypool_ag ) =ccohort_hydr%th_ag(:) + th_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%th_troot(:) + flc_min_node( 1 : n_hypool_ag ) =ccohort_hydr%flc_min_ag(:) + flc_min_node((n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%flc_min_troot(:) + + + do k = 1, n_hypool_ag+n_hypool_troot + call psi_from_th(ft, porous_media(k), th_node(k), psi_node(k),site_hydr, bc_in) + call dpsidth_from_th(ft, porous_media(k), th_node(k),dpsidth_node(k), site_hydr, bc_in) + call flc_from_psi(ft, porous_media(k), psi_node(k), flc_node(k),site_hydr, bc_in) + call dflcdpsi_from_psi(ft, porous_media(k), psi_node(k),dflcdpsi_node(k), site_hydr, bc_in) + + if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then + if(flc_node(k) > flc_min_node(k)) then + dflcdpsi_node(k) = 0._r8 + flc_node(k) = flc_min_node(k) + end if + end if + enddo - -! psi_node(1:npool_bg) = psi_node_1l(1:npool_bg) -! th_node(1:npool_bg) = th_node_1l(1:npool_bg) - num_nds = n_hypool_ag + n_hypool_troot - - do j = 1,site_hydr%nlevsoi_hyd + num_nds = n_hypool_ag + n_hypool_troot + + do j = 1,site_hydr%nlevsoi_hyd th_node_1l((n_hypool_ag+n_hypool_troot+1)) = ccohort_hydr%th_aroot(j) th_node_1l((n_hypool_ag+n_hypool_troot+2):(n_hypool_tot)) = site_hydr%h2osoi_liqvol_shell(j,:) do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - num_nds = num_nds + 1 - call psi_from_th(ft, pm_type(num_nds), th_node_1l(k),psi_node_1l(k),site_hydr, bc_in) - call flc_from_psi(ft, pm_type(num_nds),psi_node_1l(k), flc_node_1l(k), site_hydr, bc_in) - call dflcdpsi_from_psi(ft, pm_type(num_nds),psi_node_1l(k), dflcdpsi_node_1l(k), site_hydr, bc_in) - - if(k == n_hypool_ag + n_hypool_troot + 1) then - if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then - if(flc_node_1l(k) > ccohort_hydr%flc_min_aroot(j)) then - dflcdpsi_node_1l(num_nds) = 0._r8 - flc_node_1l(num_nds) = ccohort_hydr%flc_min_aroot(j) - end if - end if - flc_node(num_nds) = flc_node_1l(k) - dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) - else - flc_node(num_nds) = flc_node_1l(k) - dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) - if(k==n_hypool_tot) outer_nodes(j) = num_nds - endif - psi_node(num_nds) = psi_node_1l(k) - th_node(num_nds) = th_node_1l(k) + num_nds = num_nds + 1 + call psi_from_th(ft, pm_type(num_nds), th_node_1l(k),psi_node_1l(k),site_hydr, bc_in) + call flc_from_psi(ft, pm_type(num_nds),psi_node_1l(k), flc_node_1l(k), site_hydr, bc_in) + call dflcdpsi_from_psi(ft, pm_type(num_nds),psi_node_1l(k), dflcdpsi_node_1l(k), site_hydr, bc_in) + + if(k == n_hypool_ag + n_hypool_troot + 1) then + if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then + if(flc_node_1l(k) > ccohort_hydr%flc_min_aroot(j)) then + dflcdpsi_node_1l(num_nds) = 0._r8 + flc_node_1l(num_nds) = ccohort_hydr%flc_min_aroot(j) + end if + end if + flc_node(num_nds) = flc_node_1l(k) + dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) + else + flc_node(num_nds) = flc_node_1l(k) + dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) + if(k==n_hypool_tot) outer_nodes(j) = num_nds + endif + psi_node(num_nds) = psi_node_1l(k) + th_node(num_nds) = th_node_1l(k) enddo -! h2osoi_liqvol = min(bc_in%eff_porosity_sl(j), & -! bc_in%h2o_liq_sisl(j)/(bc_in%dz_sisl(j)*denh2o)) -! call swcCampbell_psi_from_th(h2osoi_liqvol, & -! bc_in%watsat_sisl(j), (-1.0_r8)*bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8, bc_in%bsw_sisl(j), smp) - enddo - th_node_init(:) = th_node(:) - psi_node_init(:) = psi_node(:) -! - nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot -! - rlfx = 1._r8 - rlfx1 = 0.15_r8 - rsdp = 0._r8 - inewt = 0 - tmx = dtime - dtime_o = dtime - tm = 0 - ntsr = 0 - dth_layershell(:,:) = 0._r8 - do while(tm < tmx) - rlfx = 0.6_r8 - !rlfx1 = 0.15_r8 - rlfx1 = 0.1_r8 - rsdp = 0._r8 - inewt = 0 - 100 continue - tm = tm + dtime - niter = 0 - itshk = 0 - e0(:) = 0 - e1(:) = 0 - e2(:) = 0 - 200 continue - niter = niter + 1 -!zero matrix and residual - if(inewt == 0) then + enddo + th_node_init(:) = th_node(:) + psi_node_init(:) = psi_node(:) + ! + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot + ! + rlfx = 1._r8 + rlfx1 = 0.15_r8 + rsdp = 0._r8 + inewt = 0 + tmx = dtime + dtime_o = dtime + tm = 0 + ntsr = 0 + dth_layershell(:,:) = 0._r8 + do while(tm < tmx) + rlfx = 0.6_r8 + !rlfx1 = 0.15_r8 + rlfx1 = 0.1_r8 + rsdp = 0._r8 + inewt = 0 +100 continue + tm = tm + dtime + niter = 0 + itshk = 0 + e0(:) = 0 + e1(:) = 0 + e2(:) = 0 +200 continue + niter = niter + 1 + !zero matrix and residual + if(inewt == 0) then ajac(:,:) = 0._r8 - endif - residual(:) = 0._r8 - blu(:) = 0._r8 -! - do k = 1, num_nodes - call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) - call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) - enddo - - call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) + endif + residual(:) = 0._r8 + blu(:) = 0._r8 + ! + do k = 1, num_nodes + call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) + call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) + enddo - do k=1,num_nodes -! - residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) -! matrix - ic(:) = 0 - ir(:) = 0 - values(:) = 0._r8 - nc = 1 - nr = 1 - icol = k - ic(1) = icol - ir(1) = icol -! dnr = -1.e-6_r8 -! dnr = -0.005*abs(psi_node(k)) - 1e-12 - dnr = -1.e-8_r8 -! dnr = -max(1.e-6,0.05*abs(psi_node(k))) - if(pm_type(k) <= nt_ab) then - call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) -! incremented psi + call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) + + do k=1,num_nodes + ! + residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) + ! matrix + ic(:) = 0 + ir(:) = 0 + values(:) = 0._r8 + nc = 1 + nr = 1 + icol = k + ic(1) = icol + ir(1) = icol + ! dnr = -1.e-6_r8 + ! dnr = -0.005*abs(psi_node(k)) - 1e-12 + dnr = -1.e-8_r8 + ! dnr = -max(1.e-6,0.05*abs(psi_node(k))) + if(pm_type(k) <= nt_ab) then + call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) + ! incremented psi psi_pt = psi_node(k) + dnr call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr @@ -4615,306 +4588,196 @@ subroutine Hydraulics_alt_1DSolve(dtime, s, cc_p,ft, qtop, site_hydr,ccohort_hyd values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp endif if(inewt == 0) then -! call MatSetValues( fmat,nr,ir(1),nc,ic(1),values(1),ADD_VALUES,ierr ) - ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) + ! call MatSetValues( fmat,nr,ir(1),nc,ic(1),values(1),ADD_VALUES,ierr ) + ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) end if - enddo + enddo -! calculate boundary fluxes - nr = 2 - nc = 2 - do icnx=1,num_connections - id_dn = conn_dn(icnx) - id_up = conn_up(icnx) - ir(:) = 0 - ic(:) = 0 - values(:) = 0._r8 - qflx = -1._r8 * k_bound(icnx) * hdiff_bound(icnx) - if(icnx==2) sapflow =qflx - q_flux(icnx) = qflx - residual(id_dn) = residual(id_dn) - qflx - residual(id_up) = residual(id_up) + qflx - dqflx_dn = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,1) + k_bound(icnx)*dhdpsi(icnx,1)) - dqflx_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) - ir(1) = id_dn - ir(2) = id_up - ic(1) = id_dn - ic(2) = id_up - values(1) = -dqflx_dn - values(2) = -dqflx_up - values(3) = dqflx_dn - values(4) = dqflx_up - if(inewt == 0) then -! call MatSetValues( fmat,nr,ir,nc,ic,values,ADD_VALUES,ierr ) - ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) - ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) - end if - enddo -! - residual(1) = residual(1) + qtop -! call dflcgsdpsi_from_psi(psi_node(1),ft, dflcgsdpsi) -! dflcgsdth = dflcgsdpsi -! dqtopdflcgs = 0.1411985_r8 !BOC... estimated by trial-and-error:this term multiplied by the maximum value of dflcgsdth gives 150. - !NEEDED: an estimate for dqtopdflcgs - !that accounts for variable potential - !evapotranspiration (efpot). - - ! SET THE DQTOPDTH_LEAF TERM -! if(do_dqtopdth_leaf) then -! dqtopdth_leaf = dqtopdflcgs * dflcgsdth -! if(mono_decr_Rn .and. ccohort_hydr%psi_ag(1) >= -0.88_r8) then -! dqtopdth_leaf = 0._r8 -! else if(ccohort_hydr%psi_ag(1) < -0.88_r8) then -! dqtopdth_leaf = 150._r8 -! else -! dqtopdth_leaf = 0._r8 -! end if -! else -! dqtopdth_leaf = 0._r8 -! end if -! nr = 1 -! nc = 1 -! ir(1) = 0 -! ic(1) = 0 -! call MatSetValues( fmat,nr,ir,nc,ic,dqtopdth_leaf,ADD_VALUES,ierr ) - - residual(:) = -residual(:) -! call petsc_put_rhs(residual, frhs_vec) -! - icnv = 3 -! call petsc_solve(fksp,fmat,frhs_vec,fsol_vec) -! call petsc_get_solution(blu,fsol_vec) - !call ludcmp(ajac,num_nodes,indices,dcomp) - !call lubksb(ajac,num_nodes,indices,residual) - !CALL DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -! check residual -!if(nstep==15764) print *,'ft,it,rsd-',ft,niter,rsd,'qtop',qtop,psi_node,'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node - rsd = 0._r8 - nsd = 0 - do k = 1, num_nodes - rsdx = abs(residual(k)) -! check NaNs - if( rsdx /= rsdx ) then - icnv = 1 - exit - endif - if( rsdx > rsd ) then - rsd = rsdx - nsd = k - endif - enddo -! matrix no update if inewt = 1 -! if( niter > 100 .and. rsd < 1.e-1) inewt = 1 - if(icnv == 1) goto 199 - rsdp = rsd -! check convergence - if( rsd > 1.e-8_r8 ) then - icnv = 2 - !endif - call ludcmp(ajac,num_nodes,indices,dcomp) - call lubksb(ajac,num_nodes,indices,residual) - - info = 0 -! call dgelg(residual,ajac,num_nodes,num_nodes,1.e-14_r8,info) - !call dgesv(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) - - if ( info == -1 ) then - write(fates_log(),*) 'singular matrix in dgesv' !There is a row of zeros. - call endrun(msg=errMsg(sourcefile, __LINE__)) - END IF - blu(:) = residual(:) - -! update pressure -! limit pressure change - do k = 1, num_nodes - if(pm_type(k) >= 4) then -! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx1 -!if(abs(blu(k))> abs(psi_node(k))) then -! psi_node(k) = psi_node(k) + blu(k)*rlfx1*0.5 -!else - psi_node(k) = psi_node(k) + blu(k)*rlfx1 -!endif + ! calculate boundary fluxes + nr = 2 + nc = 2 + do icnx=1,num_connections + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + ir(:) = 0 + ic(:) = 0 + values(:) = 0._r8 + qflx = -1._r8 * k_bound(icnx) * hdiff_bound(icnx) + if(icnx==2) sapflow =qflx + q_flux(icnx) = qflx + residual(id_dn) = residual(id_dn) - qflx + residual(id_up) = residual(id_up) + qflx + dqflx_dn = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,1) + k_bound(icnx)*dhdpsi(icnx,1)) + dqflx_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) + ir(1) = id_dn + ir(2) = id_up + ic(1) = id_dn + ic(2) = id_up + values(1) = -dqflx_dn + values(2) = -dqflx_up + values(3) = dqflx_dn + values(4) = dqflx_up + if(inewt == 0) then + ! call MatSetValues( fmat,nr,ir,nc,ic,values,ADD_VALUES,ierr ) + ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) + ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) + end if + enddo + ! + residual(1) = residual(1) + qtop - else -! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx - psi_node(k) = psi_node(k) + blu(k) * rlfx - endif - - enddo - endif - if( icnv == 2 .and. niter > 200) then - icnv = 1 - endif - if(niter > 500) then + residual(:) = -residual(:) + + icnv = 3 + + ! CALL DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) + + ! check residual + !if(nstep==15764) print *,'ft,it,rsd-',ft,niter,rsd,'qtop',qtop,psi_node,'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node + rsd = 0._r8 + nsd = 0 + do k = 1, num_nodes + rsdx = abs(residual(k)) + ! check NaNs + if( rsdx /= rsdx ) then + icnv = 1 + exit + endif + if( rsdx > rsd ) then + rsd = rsdx + nsd = k + endif + enddo + ! matrix no update if inewt = 1 + ! if( niter > 100 .and. rsd < 1.e-1) inewt = 1 + if(icnv == 1) goto 199 + rsdp = rsd + ! check convergence + if( rsd > 1.e-8_r8 ) then + icnv = 2 + + info = 0 + + call DGESV(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) + + if ( info == -1 ) then + write(fates_log(),*) 'singular matrix in dgesv' !There is a row of zeros. + call endrun(msg=errMsg(sourcefile, __LINE__)) + END IF + blu(:) = residual(:) + + ! update pressure + ! limit pressure change + do k = 1, num_nodes + if(pm_type(k) >= 4) then + ! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx1 + !if(abs(blu(k))> abs(psi_node(k))) then + ! psi_node(k) = psi_node(k) + blu(k)*rlfx1*0.5 + !else + psi_node(k) = psi_node(k) + blu(k)*rlfx1 + !endif + + else + ! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx + psi_node(k) = psi_node(k) + blu(k) * rlfx + endif + + enddo + endif + if( icnv == 2 .and. niter > 200) then + icnv = 1 + endif + if(niter > 500) then rlfx = 0.4_r8 rlfx1 = 0.1_r8 - end if -199 continue - if( icnv == 1 ) then - write(*,'(10x,a)') '--- Convergence Failure ---' - write(*,'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & - rsd,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) - if( ntsr < 10 ) then - tm = tm - dtime - ntsr = ntsr + 1 - dtx = dtime - dtcf = 0.2_r8 - dtimex = dtime * dtcf - dtime = min(dtimex,tmx-tm) - dto = dtime - var = dtime - varx = dtx - write(*,'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & - 'Time Step Reduced From ',varx,'s',' to ', & - var,'s' - do k = 1,num_nodes - psi_node(k) = psi_node_init(k) - th_node(k) = th_node_init(k) - enddo - rlfx = 0.6_r8 - rlfx1 = 0.15_r8 -! -!--- Number of time step reductions failure: stop simulation --- -! - else - write(*,'(10x,a)') '--- Time Step Reduction Limit Exceeded---' - icnv = 4 - endif - endif - do k=1,num_nodes - call th_from_psi(ft,pm_type(k),psi_node(k),th_node(k),site_hydr,bc_in) - enddo - if(icnv == 1) then - goto 100 - elseif(icnv == 2) then - goto 200 - elseif(icnv == 3) then - dth_node(:) = th_node(:) - th_node_init(:) - goto 201 - else - stop - endif -! enddo - 201 continue - - ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) - ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) - ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) - ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - ccohort_hydr%psi_troot(1:n_hypool_troot) = psi_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) - num_nds = n_hypool_ag+n_hypool_troot - n_hypool_at = n_hypool_ag + n_hypool_troot + 1 - do j = 1,site_hydr%nlevsoi_hyd + end if +199 continue + if( icnv == 1 ) then + write(*,'(10x,a)') '--- Convergence Failure ---' + write(*,'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & + rsd,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) + if( ntsr < 10 ) then + tm = tm - dtime + ntsr = ntsr + 1 + dtx = dtime + dtcf = 0.2_r8 + dtimex = dtime * dtcf + dtime = min(dtimex,tmx-tm) + dto = dtime + var = dtime + varx = dtx + write(*,'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & + 'Time Step Reduced From ',varx,'s',' to ', & + var,'s' + do k = 1,num_nodes + psi_node(k) = psi_node_init(k) + th_node(k) = th_node_init(k) + enddo + rlfx = 0.6_r8 + rlfx1 = 0.15_r8 + ! + !--- Number of time step reductions failure: stop simulation --- + ! + else + write(*,'(10x,a)') '--- Time Step Reduction Limit Exceeded---' + icnv = 4 + endif + endif + do k=1,num_nodes + call th_from_psi(ft,pm_type(k),psi_node(k),th_node(k),site_hydr,bc_in) + enddo + if(icnv == 1) then + goto 100 + elseif(icnv == 2) then + goto 200 + elseif(icnv == 3) then + dth_node(:) = th_node(:) - th_node_init(:) + goto 201 + else + stop + endif + ! enddo +201 continue + + ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) + ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) + ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) + ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%psi_troot(1:n_hypool_troot) = psi_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) + num_nds = n_hypool_ag+n_hypool_troot + n_hypool_at = n_hypool_ag + n_hypool_troot + 1 + do j = 1,site_hydr%nlevsoi_hyd do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - num_nds = num_nds + 1 - if(k==n_hypool_at) then - ccohort_hydr%th_aroot(j) = th_node(num_nds) - ccohort_hydr%psi_aroot(j) = psi_node(num_nds) - ccohort_hydr%flc_aroot(j) = flc_node(num_nds) - dwat_veg_coh = dwat_veg_coh + dth_node(num_nds) * v_node(num_nds) - else - ksh = k-n_hypool_at - dth_layershell(j,ksh) = dth_layershell(j,ksh) + & - (th_node(num_nds) - th_node_init(num_nds)) * & - ccohort_hydr%l_aroot_layer(j) * & - ccohort%n /site_hydr%l_aroot_layer(j) * dtime - endif + num_nds = num_nds + 1 + if(k==n_hypool_at) then + ccohort_hydr%th_aroot(j) = th_node(num_nds) + ccohort_hydr%psi_aroot(j) = psi_node(num_nds) + ccohort_hydr%flc_aroot(j) = flc_node(num_nds) + dwat_veg_coh = dwat_veg_coh + dth_node(num_nds) * v_node(num_nds) + else + ksh = k-n_hypool_at + dth_layershell(j,ksh) = dth_layershell(j,ksh) + & + (th_node(num_nds) - th_node_init(num_nds)) * & + ccohort_hydr%l_aroot_layer(j) * & + ccohort%n /site_hydr%l_aroot_layer(j) * dtime + endif enddo - enddo - dwat_veg_coh = dwat_veg_coh * denh2o - site_hydr%dwat_veg = site_hydr%dwat_veg+ dwat_veg_coh*ccohort%n/AREA!*patch_wgt - site_hydr%h2oveg = site_hydr%h2oveg +dwat_veg_coh*ccohort%n/AREA!*patch_wgt - th_node_init(:) = th_node(:) - psi_node_init(:) = psi_node(:) - enddo - dth_layershell(:,:) = dth_layershell(:,:) / dtime_o - end associate - - return - end subroutine hydraulics_alt_1DSolve - - ! ===================================================================================== - subroutine initHydrSolver(sites,bc_in) - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) - - ! Local - type(ed_site_hydr_type), pointer :: site_hydr - integer :: nsites - integer :: nlevsoil ! Number of soil layers - integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers - integer :: num_cnxs - integer :: num_nds - integer :: num_connections - integer :: node_tr_end - integer :: nt_ab - integer :: j, k, s - integer, dimension(:),allocatable :: conn_dn - integer, dimension(:),allocatable :: conn_up -! - if(hlm_use_alt_planthydro.eq.ifalse) return - ! number of connections between organs, root/shell -! - nsites = ubound(sites,1) - - do s = 1,nsites - site_hydr => sites(s)%si_hydr - - nlevsoil = bc_in(s)%nlevsoil - nlevsoil_hyd = site_hydr%nlevsoi_hyd - num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & - + (n_hypool_aroot + nshell) * nlevsoil_hyd - allocate(conn_dn(num_connections)) - allocate(conn_up(num_connections)) - - conn_dn = 0 - conn_up = 0 -! - num_cnxs = 0 - do k = 1, n_hypool_leaf - num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom - conn_up(num_cnxs) = k + 1 - enddo - do k = n_hypool_leaf+1, n_hypool_ag - num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k - conn_up(num_cnxs) = k+1 - enddo - - num_nds = n_hypool_ag+n_hypool_troot - node_tr_end = num_nds - nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot - num_cnxs = n_hypool_ag - do j = 1,nlevsoil_hyd + enddo + dwat_veg_coh = dwat_veg_coh * denh2o + site_hydr%dwat_veg = site_hydr%dwat_veg+ dwat_veg_coh*ccohort%n/AREA!*patch_wgt + site_hydr%h2oveg = site_hydr%h2oveg +dwat_veg_coh*ccohort%n/AREA!*patch_wgt + th_node_init(:) = th_node(:) + psi_node_init(:) = psi_node(:) + enddo + dth_layershell(:,:) = dth_layershell(:,:) / dtime_o + end associate - do k = 1, n_hypool_aroot + nshell - num_nds = num_nds + 1 - num_cnxs = num_cnxs + 1 - if( k == 1 ) then !troot-aroot - !junction node - conn_dn(num_cnxs) = node_tr_end !absorbing root - conn_up(num_cnxs) = num_nds - - else - conn_dn(num_cnxs) = num_nds - 1 - conn_up(num_cnxs) = num_nds - endif - enddo -! - enddo ! end soil layer -! call petsc_solver_init(fksp,fmat,frhs_vec,fsol_vec, & -! conn_dn, conn_up) - - deallocate(conn_dn) - deallocate(conn_up) - end do -! - end subroutine initHydrSolver + return + end subroutine hydraulics_alt_1DSolve - + ! ===================================================================================== subroutine InitHydroGlobals() diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index eedb0e9342..81ad0975e9 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -136,9 +136,20 @@ module FatesHydraulicsMemMod class(wrf_arr_type), pointer :: wrf_soil(:) ! Water retention function for soil layers class(wkf_arr_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil + ! For the matrix version of the solver we need to define the connection + ! and type map for the whole system of compartments, from the soil to leaf + ! as one vector + + integer, parameter, public :: num_connections + integer, allocatable, public, protected :: conn_up(:) + integer, allocatable, public, protected :: conn_dn(:) + integer, allocatable, public, protected :: pm_type(:) + + contains - procedure :: InitHydrSite + procedure :: InitHydrSite + procedure :: SetConnections end type ed_site_hydr_type @@ -368,12 +379,67 @@ subroutine InitHydrSite(this) allocate(this%wrf_soil(1:nlevsoil_hyd)) allocate(this%wkf_soil(1:nlevsoil_hyd)) + if(use_2d_hydrosolve) then + + this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + + (n_hypool_aroot + nshell) * nlevsoil_hyd + + + allocate(this%conn_up(this%num_connections)) + allocate(this%conn_dn(this%num_connections)) + + end if + end associate return end subroutine InitHydrSite + subroutine SetConnections(this) + + class(ed_site_hydr_type),intent(inout) :: this + + integer :: k, j + integer :: num_cnxs + integer :: num_nds + integer :: nt_ab + + num_cnxs = 0 + do k = 1, n_hypool_leaf + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom + conn_up(num_cnxs) = k + 1 + enddo + do k = n_hypool_leaf+1, n_hypool_ag + num_cnxs = num_cnxs + 1 + conn_dn(num_cnxs) = k + conn_up(num_cnxs) = k+1 + enddo + + num_nds = n_hypool_ag+n_hypool_troot + node_tr_end = num_nds + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot + num_cnxs = n_hypool_ag + + do j = 1,this%nlevsoil_hyd + do k = 1, n_hypool_aroot + nshell + num_nds = num_nds + 1 + num_cnxs = num_cnxs + 1 + if( k == 1 ) then !troot-aroot + !junction node + conn_dn(num_cnxs) = node_tr_end !absorbing root + conn_up(num_cnxs) = num_nds + else + conn_dn(num_cnxs) = num_nds - 1 + conn_up(num_cnxs) = num_nds + endif + enddo + end do + + end subroutine SetConnections + + ! ===================================================================================== subroutine SetPhsOrganConnection(this) ! From 54c37a6adb13006fd8e28371e1a6c40e9e3b732e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 10 Jan 2020 16:55:15 -0800 Subject: [PATCH 047/114] Refactors to the 1D solver to make it modular by cohort, which will align better with a call to matrix solver. Added runoff boundary condition. --- biogeophys/FatesPlantHydraulicsMod.F90 | 1361 ++++++++++++------------ main/FatesHydraulicsMemMod.F90 | 4 +- main/FatesInterfaceMod.F90 | 8 +- 3 files changed, 709 insertions(+), 664 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index c476fc0031..9e597af65c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -143,7 +143,9 @@ module FatesPlantHydraulicsMod - + real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer + ! is left between soil moisture and saturation [m3/m3] + logical,parameter :: debug = .true. !flag to report warning in hydro @@ -694,7 +696,6 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdateTreeHydrNodes is called prior to this. - call UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! This updates the Kmax's of the plant's compartments @@ -1448,7 +1449,7 @@ end subroutine UpdateH2OVeg subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! ---------------------------------------------------------------------------------- - ! This subroutine is called to caluate the water requirement for newly recruited cohorts + ! This subroutine is called to calculate the water requirement for newly recruited cohorts ! The water update is allocated proportionally to the root biomass, which could be updated ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). ! After the root water uptake, is_newly_recruited flag is set to false. @@ -2200,21 +2201,16 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] - ! cohort-specific arrays to hold 1D hydraulics geometric & state variables for entire continuum (leaf,stem,root,soil) - real(r8) :: th_node(n_hypool_tot) ! volumetric water in water storage compartments [m3 m-3] - real(r8) :: dth_node(n_hypool_tot) ! change in volumetric water in water storage compartments [m3 m-3] - real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] - - ! column-specific arrays to hold rhizosphere geometric & state variables real(r8) :: h2osoi_liqvol - + real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create + ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] real(r8) :: aroot_frac_plant ! The fraction of the total lenght of absorbing roots contained in one soil layer ! that are devoted to a single plant - + real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: psi_aroot ! matric potential in absorbing root [MPa] real(r8) :: ftc_aroot ! fraction of total conductance in absorbing root [-] real(r8) :: psi_shell ! matric potential of a given shell [-] @@ -2226,8 +2222,13 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: wb_error_site ! Error reflecting difference between site storage before and after ! integration, with the change in the uptake boundary condition ! that we send to the HLM. [kg/m2] - real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation - ! or sub-residual water contents from occuring in the soil [kg/m2] + real(r8) :: wb_check_site ! the water balance error we get from summing fluxes + ! and changes in storage (this should match wb_error_site, + ! and is just a double check on our error accounting). [kg/m2] + + +! real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation +! ! or sub-residual water contents from occuring in the soil [kg/m2] ! hydraulics other @@ -2260,7 +2261,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: pick_1l(nshell+1) = (/(k,k=n_hypool_ag+n_hypool_troot+1,n_hypool_tot,1)/) real(r8) :: roota, rootb ! parameters for root distribution [m-1] real(r8) :: rootfr ! root fraction at different soil layers - real(r8) :: prev_h2oveg ! previous time step plant water storage (kg/m2) + real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) + real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) logical :: recruitflag ! flag to check if there is newly recruited cohorts integer :: iter ! number of solver iterations used for each cohort x layer integer :: nsteps ! number of substeps used for the final iteration on linear solve @@ -2305,23 +2307,24 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr => sites(s)%si_hydr ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN - dth_layershell_col(:,:) = 0._r8 + dth_layershell_col(:,:) = 0._r8 site_hydr%dwat_veg = 0._r8 site_hydr%errh2o_hyd = 0._r8 prev_h2oveg = site_hydr%h2oveg - + prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV + + wb_error_site = 0._r8 + ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- transp_flux = 0._r8 root_flux = 0._r8 + site_runoff = 0._r8 ! Initialize the delta in soil water and plant water storage ! with the initial condition. - delta_plant_storage = site_hydr%h2oveg - delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - !err_soil = delta_soil_storage - root_flux !err_plot = delta_plant_storage - (root_flux - transp_flux) @@ -2436,9 +2439,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) if(use_2d_hydrosolve) then - call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & - dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake,wb_error,iter,nsteps) + ! call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & + ! dtime,qflx_tran_veg_indiv, & + ! sapflow,rootuptake,wb_error_site,iter,nsteps) else @@ -2458,12 +2461,13 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! layers have transporting-to-absorbing root water potential gradients of opposite sign ! ----------------------------------------------------------------------------------- - call OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered) + call OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered,kbg_layer) call ImTaylorSolve1D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv,ordered, & - sapflow,rootuptake,wb_error,nsteps) - + dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & + sapflow,rootuptake,wb_error_site,nsteps, & + dth_layershell_col,site_runoff) + end if ! --------------------------------------------------------- @@ -2478,96 +2482,69 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) enddo !cohort cpatch => cpatch%younger - enddo !patch - + enddo !patch + ! -------------------------------------------------------------------------------- + ! The cohort level water fluxes are complete, the remainder of this subroutine + ! is dedicated to doing site level resulting mass balance calculations and checks + ! -------------------------------------------------------------------------------- ! Calculate the amount of water fluxing through the roots. It is the sum ! of the change in thr rhizosphere shells. Note that following this calculation ! we may adjust the change in soil water to avoid super-saturation and sub-residual ! water contents. But the pre-adjusted value is the actual amount of root flux. + ! [kg/m2] root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - - ! In this section we evaluate the water content in the rhizosphere - ! and apply constraints, so that the water contents are not above saturation - ! or below residual. - - site_hydr%supsub_flag(:) = 999 - supsub_error = 0._r8 + do j=1,site_hydr%nlevsoi_hyd - - watres_local = site_hydr%wrf_soil(j)%p%th_from_psi(bc_in(s)%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) - do k=1,nshell - if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) > & - (bc_in(s)%watsat_sisl(j)-small_theta_num)) then - - ! We are destroying water in this case [kg/m2] - supsub_error = supsub_error - site_hydr%v_shell(j,k)*denh2o*AREA_INV* & - (site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k) - (bc_in(s)%watsat_sisl(j)-small_theta_num)) - - ! Change dth_layer_shell to reflect the bounded soil moisture - dth_layershell_col(j,k) = (bc_in(s)%watsat_sisl(j)-small_theta_num) - site_hydr%h2osoi_liqvol_shell(j,k) - - ! Flag that a superaturation problem was encountered here - site_hydr%supsub_flag(j) = k - - else if ((site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k)) < & - (watres_local+small_theta_num)) then - - ! We are creating water [kg/m2] - supsub_error = supsub_error + site_hydr%v_shell(j,k)*denh2o*AREA_INV* & - ((watres_local+small_theta_num) - (site_hydr%h2osoi_liqvol_shell(j,k)+dth_layershell_col(j,k))) - - ! Change dth_layer_shell to reflect the bounded soil moisture - dth_layershell_col(j,k) = ( watres_local+small_theta_num ) - site_hydr%h2osoi_liqvol_shell(j,k) - - ! Flag that a super-saturation problem was encountered here - site_hydr%supsub_flag(j) = -k + ! Update the site-level state variable + ! rhizosphere shell water content [m3/m3] + site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & + dth_layershell_col(j,:) - end if - - site_hydr%h2osoi_liqvol_shell(j,k) = site_hydr%h2osoi_liqvol_shell(j,k) + & - dth_layershell_col(j,k) - enddo + if(site_hydr%recruit_w_uptake(j) > nearzero) then + write(fates_log(),*) 'turn off recruitment for now' + write(fates_log(),*) 'can turn on again after results stabilize' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - - !qflx_rootsoi(c,j) = -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) - bc_out(s)%qflx_soil2root_sisl(j) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & - site_hydr%recruit_w_uptake(j) - - ! h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - ! bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) + bc_out(s)%qflx_soil2root_sisl(j) = & + -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & + site_hydr%recruit_w_uptake(j) ! Save the amount of liquid soil water known to the model after root uptake ! This calculation also assumes that 1mm of water is 1kg site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & dtime*bc_out(s)%qflx_soil2root_sisl(j) - enddo !site_hydr%nlevsoi_hyd + enddo - delta_plant_storage = site_hydr%h2oveg - delta_plant_storage + ! Note that the cohort-level solvers are expected to update + ! site_hydr%h2oveg + + delta_plant_storage = site_hydr%h2oveg - prev_h2oveg - delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - delta_soil_storage + delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-6_r8 ) then + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-6_r8 ) then write(fates_log(),*) 'Site plant water balance does not close' write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' write(fates_log(),*) 'end storage: ',site_hydr%h2oveg call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(abs(delta_soil_storage + root_flux - supsub_error) > 1.e-6_r8 ) then + end if + + if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-6_r8 ) then write(fates_log(),*) 'Site soil water balance does not close' write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' - write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' + write(fates_log(),*) 'integrated root flux (pos into root): ',root_flux,' [kg/m2]' + write(fates_log(),*) 'site runoff: ',site_runoff,' [kg/m2]' write(fates_log(),*) 'end storage: ',sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV, & ' [kg/m2]' @@ -2584,15 +2561,45 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:) - & site_hydr%recruit_w_uptake(:))*dtime - wb_error_site = site_hydr%h2oveg-(prev_h2oveg + totalrootuptake - transp_flux) - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site + supsub_error + ! Compare the integrated error to the site mass balance + ! error sign is positive towards transpiration overestimation + ! Loss fluxes should = decrease in storage + ! (transp_flux + site_runoff) = -(delta_plant_storage+delta_soil_storage ) + + wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux + + if( abs(wb_check_site - wb_error_site) > 1.e-10_r8 ) then + write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]' + write(fates_log(),*) 'wb_error_site: ',wb_error_site + write(fates_log(),*) 'wb_check_site: ',wb_check_site + write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage + write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage + write(fates_log(),*) 'site_runoff: ',site_runoff + write(fates_log(),*) 'transp_flux: ',transp_flux + end if + + ! Now check on total error + if( abs(wb_check_site) > 1.e-6_r8 ) then + write(fates_log(),*) 'FATES hydro water balance does not add up [kg/m2]' + write(fates_log(),*) 'wb_check_site: ',wb_check_site + write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage + write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage + write(fates_log(),*) 'site_runoff: ',site_runoff + write(fates_log(),*) 'transp_flux: ',transp_flux + end if + + + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & site_hydr%h2oveg_growturn_err - & site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err + ! [kg/m2] -> [mm/s] + bc_out(s)%qflx_runoff_si = site_runoff/dtime + !write(fates_log(),*) 'hydro wb terms: --------------------------' !write(fates_log(),*) site_hydr%h2oveg !write(fates_log(),*) site_hydr%h2oveg_dead @@ -2872,7 +2879,7 @@ end subroutine UpdatePlantKmax ! =================================================================================== - subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) + subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) ! Arguments (IN) type(ed_site_hydr_type), intent(in),target :: site_hydr @@ -2881,6 +2888,7 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) ! Arguments (INOUT) integer, intent(inout) :: ordered(:) + real(r8), intent(out) :: kbg_layer(:) ! Locals @@ -2901,7 +2909,9 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) integer :: j,jj,k ! layer and shell indices - kbg_tot = 0._r8 + kbg_tot = 0._r8 + kbg_layer(:) = 0._r8 + do j=1,site_hydr%nlevsoi_hyd ! Path is between the absorbing root @@ -2955,6 +2965,9 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) enddo !soil layer + + kbg_layer = kbg_layer/kbg_tot + ! order soil layers in terms of decreasing volumetric water content ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents do j = site_hydr%nlevsoi_hyd-1,1,-1 @@ -2972,9 +2985,9 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered ) end subroutine OrderLayersForSolve1D ! ================================================================================= - - subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_top, & - dth_node,sapflow,rootuptake,wb_err,nsteps) + + subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & + ordered,kbg_layer,sapflow,rootuptake,wb_err_site,nsteps,dth_layershell_col, runoff) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -2995,42 +3008,53 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t type(ed_cohort_type),intent(in),target :: cohort type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr type(ed_site_hydr_type), intent(in),target :: site_hydr - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions - integer, intent(in) :: ilayer ! soil layer index of interest - real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8), intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions + real(r8), intent(in) :: dtime + real(r8), intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + integer,intent(in) :: ordered(:) ! Layer solution order + real(r8), intent(in) :: kbg_layer(:) ! relative conductance of each layer + ! Arguments (OUT) - real(r8),intent(out) :: dth_node(n_hypool_tot) ! change in theta over the timestep - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - real(r8),intent(out) :: wb_err ! error, transpiration should match change in storage [kg] - integer,intent(out) :: iter ! iteration count for sub-step loops - integer,intent(out) :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(inout) :: wb_err_site ! total error over site, transpiration + ! should match change in storage [kg/m2] + integer,intent(out) :: iter ! iteration count for sub-step loops + integer,intent(out) :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows + real(r8),intent(inout) :: dth_layershell_col(:,:) ! accumulated water content change over all cohorts in a column [m3 m-3]) + real(r8),intent(inout) :: runoff ! mass of water generated by preventing super-saturation of soils [kg/m2] ! Locals - integer :: i ! node index "i" - integer :: j ! path index "j" - integer :: itest ! node index used for testing and reporting errors - integer :: ishell ! rhizosphere shell index of the node - integer :: ishell_up ! rhizosphere shell index on the upper side of flow path - integer :: ishell_lo ! rhizosphere shell index on the lower side of flow path - integer :: i_up ! node index on the upper (closer to atm) side of current flow-path - integer :: i_lo ! node index on the lower (away from atm) side of current flow-path - integer :: istep ! sub-step count index + integer :: i ! node index "i" + integer :: j ! path index "j" + integer :: ilayer ! soil layer index of interest + integer :: itest ! node index used for testing and reporting errors + integer :: ishell ! rhizosphere shell index of the node + integer :: ishell_up ! rhizosphere shell index on the upper side of flow path + integer :: ishell_lo ! rhizosphere shell index on the lower side of flow path + integer :: i_up ! node index on the upper (closer to atm) side of current flow-path + integer :: i_lo ! node index on the lower (away from atm) side of current flow-path + integer :: istep ! sub-step count index logical :: solution_found ! logical set to true if a solution was found within error tolerance - real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] + real(r8) :: dt_step ! time [seconds] over-which to calculate solution + real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] real(r8) :: rootfr_scaler ! Factor to scale down cross-section areas based on what ! fraction of root is in current layer [-] - real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] - real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] - real(r8) :: wb_step_err ! water balance error over substep [kg] - real(r8) :: w_tot_beg ! total plant water prior to solve [kg] - real(r8) :: w_tot_end ! total plant water at end of solve [kg] - real(r8) :: dt_substep ! timestep length of substeps [s] - real(r8) :: leaf_water ! kg of water in the leaf - real(r8) :: stem_water ! kg of water in the stem - real(r8) :: root_water ! kg of water in the transp and absorbing roots + real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] + real(r8) :: wb_step_err ! water balance error over substep [kg] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + real(r8) :: dt_substep ! timestep length of substeps [s] + real(r8) :: leaf_water ! kg of water in the leaf + real(r8) :: stem_water ! kg of water in the stem + real(r8) :: root_water ! kg of water in the transp and absorbing roots + + real(r8) :: wb_err_layer ! balance error for the layer [kg/cohort] + real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] + + real(r8) :: dth_node(n_hypool_tot) ! change in theta over the timestep real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] ! before the solve real(r8) :: th_node(n_hypool_tot) ! "theta" during the solve (dynamic) [m3 m-3] @@ -3052,6 +3076,7 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta real(r8) :: tris_r(n_hypool_tot) ! off (constant coefficients) matrix terms + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change ! in potential [- MPa-1] @@ -3060,621 +3085,635 @@ subroutine ImTaylorSolve1D(cohort,cohort_hydr,site_hydr,bc_in,ilayer,dt_step,q_t real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) - ! out of the total absorbing roots from the whole community of plants, + ! out of the total absorbing roots from the whole community of plants integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps ! by this much integer, parameter :: max_iter = 20 ! Maximum number of iterations with which we reduce timestep real(r8), parameter :: max_wb_step_err = 1.e-7_r8 - real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [mm h2o] + real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [kg h2o] logical, parameter :: no_ftc_radialk = .false. logical, parameter :: do_scale_allkmax_rootfr = .true. - - ! to go through soil layers in order of decreasing total root-soil conductance - do jj=1,site_hydr%nlevsoi_hyd - - j = ordered(jj) - - if(do_parallel_stem) then - ! If we do "parallel" stem - ! conduits, we integrate - ! each layer over the whole time, but - ! reduce the conductance cross section - ! according to what fraction of root is active - dt_step = dtime - else - if(weight_serial_dt)then - dt_step = dtime*kbg_layer(j)/kbg_tot - else - dt_step = dtime/real(site_hydr%nlevsoi_hyd,r8) - end if - end if - + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + ccohort_hydr%iterh1 = 0 - ! ------------------------------------------------------------------------------- - ! Part 1. Calculate node quantities: - ! matric potential: psi_node - ! fraction of total conductance: ftc_node - ! total potential (matric + elevatio) h_node - ! deriv. ftc wrt theta: dftc_dtheta_node - ! deriv. psi wrt theta: dpsi_dtheta_node - ! ------------------------------------------------------------------------------- - - - ! This is the fraction of total absorbing root length that a single - ! plant for this cohort takes up. Note: - ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] - ! site_hydr%l_aroot_layer(ilayer) is units [m/site] - - aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + ! ----------------------------------------------------------------------------------- + ! As mentioned when calling this routine, we calculate a solution to the flux + ! equations, sequentially, for the plant and each soil layer. + ! Go through soil layers in order of decreasing total root-soil conductance + ! ----------------------------------------------------------------------------------- - ft = cohort%pft + do jj=1,site_hydr%nlevsoi_hyd + + ilayer = ordered(jj) + + if(do_parallel_stem) then + ! If we do "parallel" stem + ! conduits, we integrate + ! each layer over the whole time, but + ! reduce the conductance cross section + ! according to what fraction of root is active + dt_step = dtime + else + if(weight_serial_dt)then + dt_step = dtime*kbg_layer(ilayer) + else + dt_step = dtime/real(site_hydr%nlevsoi_hyd,r8) + end if + end if + + ! ------------------------------------------------------------------------------- + ! Part 1. Calculate node quantities: + ! matric potential: psi_node + ! fraction of total conductance: ftc_node + ! total potential (matric + elevatio) h_node + ! deriv. ftc wrt theta: dftc_dtheta_node + ! deriv. psi wrt theta: dpsi_dtheta_node + ! ------------------------------------------------------------------------------- + + + ! This is the fraction of total absorbing root length that a single + ! plant for this cohort takes up, relative to ALL cohorts at the site. Note: + ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] + ! site_hydr%l_aroot_layer(ilayer) is units [m/site] + + aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + + wb_err_layer = 0._r8 + + ft = cohort%pft + + ! If in "spatially parallel" mode, scale down cross section + ! of flux through top by the root fraction of this layer + + if(do_parallel_stem)then + ! Determine the root fraction that is in this layer + roota=EDPftvarcon_inst%roota_par(cohort%pft) + rootb=EDPftvarcon_inst%rootb_par(cohort%pft) + if(ilayer==1) then + rootfr_scaler = zeng2001_crootfr(roota,rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + else + rootfr_scaler = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - & + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer-1), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) + end if + if(rootfr_scaler < 0.0000001_r8) then + print*,"REALLY SMALL ROOTFR?",rootfr_scaler + stop + end if + else + rootfr_scaler = 1.0_r8 + end if + + + q_top_eff = q_top * rootfr_scaler + + ! For all nodes leaf through rhizosphere + ! Send node heights and compartment volumes to a node-based array + + do i = 1,n_hypool_tot + + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i==n_hypool_ag+1) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + elseif (i==n_hypool_ag+2) then + z_node(i) = -bc_in%z_sisl(ilayer) + v_node(i) = cohort_hydr%v_aroot_layer(ilayer) + th_node_init(i) = cohort_hydr%th_aroot(ilayer) + else + ishell = i-(n_hypool_ag+2) + z_node(i) = -bc_in%z_sisl(ilayer) + ! The volume of the Rhizosphere for a single plant + v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant + th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) + end if + + end do + + ! Outer iteration loop + ! This cuts timestep in half and resolve the solution with smaller substeps + ! This loop is cleared when the model has found a solution + + solution_found = .false. + iter = 0 + do while( .not.solution_found ) + + + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps + + sapflow = 0._r8 + rootuptake = 0._r8 + + ! Gracefully quit if too many iterations have been used + if(iter>max_iter)then + call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & + th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& + rootfr_scaler,aroot_frac_plant,error_code,error_arr) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - ! If in "spatially parallel" mode, scale down cross section - ! of flux through top by the root fraction of this layer + ! If debugging, then lets re-initialize our diagnostics of + ! time integrated K and flux across the paths + if(debug)then + k_diag = 0._r8 + flux_diag = 0._r8 + end if - if(do_parallel_stem)then - ! Determine the root fraction that is in this layer - roota=EDPftvarcon_inst%roota_par(cohort%pft) - rootb=EDPftvarcon_inst%rootb_par(cohort%pft) - if(ilayer==1) then - rootfr_scaler = zeng2001_crootfr(roota,rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - else - rootfr_scaler = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(ilayer-1), bc_in%zi_sisl(site_hydr%nlevsoi_hyd)) - end if - if(rootfr_scaler < 0.0000001_r8) then - print*,"REALLY SMALL ROOTFR?",rootfr_scaler - stop - end if - else - rootfr_scaler = 1.0_r8 - end if + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) + + ! Determine how many substeps, and how long they are - q_top_eff = q_top * rootfr_scaler - - ! For all nodes leaf through rhizosphere - ! Send node heights and compartment volumes to a node-based array - - do i = 1,n_hypool_tot - - if (i<=n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_ag(i) - v_node(i) = cohort_hydr%v_ag(i) - th_node_init(i) = cohort_hydr%th_ag(i) - elseif (i==n_hypool_ag+1) then - z_node(i) = cohort_hydr%z_node_troot - v_node(i) = cohort_hydr%v_troot - th_node_init(i) = cohort_hydr%th_troot - elseif (i==n_hypool_ag+2) then - z_node(i) = -bc_in%z_sisl(ilayer) - v_node(i) = cohort_hydr%v_aroot_layer(ilayer) - th_node_init(i) = cohort_hydr%th_aroot(ilayer) - else - ishell = i-(n_hypool_ag+2) - z_node(i) = -bc_in%z_sisl(ilayer) - ! The volume of the Rhizosphere for a single plant - v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant - th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) - end if + nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. + + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds + + ! Walk through sub-steps + do istep = 1,nsteps - end do + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o - ! Outer iteration loop - ! This cuts timestep in half and resolve the solution with smaller substeps - ! This loop is cleared when the model has found a solution + ! Calculate on-node quantities: potential, and derivatives + do i = 1,n_hypool_plant - solution_found = .false. - iter = 0 - do while( .not.solution_found ) + ! Get matric potential [Mpa] + psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) + ! Get total potential [Mpa] + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - ! These are diagnostics that must be calculated. - ! in this routine (uses differentials and actual fluxes) - ! So we need to zero them, as they are incremented - ! over the sub-steps + ! Get Fraction of Total Conductivity [-] + ftc_node(i) = wkf_plant(p_media_nodes(i),ft)%p%ftc_from_psi(psi_node(i)) - sapflow = 0._r8 - rootuptake = 0._r8 - wb_err = 0._r8 + ! deriv psi wrt theta + dpsi_dtheta_node(i) = wrf_plant(p_media_nodes(i),ft)%p%dpsidth_from_th(th_node(i)) - ! Gracefully quit if too many iterations have been used - if(iter>max_iter)then - call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & - th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& - rootfr_scaler,aroot_frac_plant,error_code,error_arr) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! deriv ftc wrt psi - ! If debugging, then lets re-initialize our diagnostics of - ! time integrated K and flux across the paths - if(debug)then - k_diag = 0._r8 - flux_diag = 0._r8 - end if + dftc_dpsi = wkf_plant(p_media_nodes(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) - ! For each attempt, we want to reset theta with the initial value - th_node(:) = th_node_init(:) + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) - ! Determine how many substeps, and how long they are + ! We have two ways to calculate radial absorbing root conductance + ! 1) Assume that water potential does not effect conductance + ! 2) The standard FTC function applies - nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. + if(i==n_hypool_ag+2)then + if(no_ftc_radialk) then + ftc_node(i) = 1.0_r8 + dftc_dtheta_node(i) = 0.0_r8 + end if + end if - dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds + end do - ! Walk through sub-steps - do istep = 1,nsteps + ! Same updates as loop above, but for rhizosphere shells + + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) + dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) + dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + end do - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node(:)*v_node(:))*denh2o - ! Calculate on-node quantities: potential, and derivatives - do i = 1,n_hypool_plant + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- + + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- + + j = 1 + i_up = 1 + i_lo = 2 + kmax_up = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf + kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! Get matric potential [Mpa] - psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) - + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do j=2,n_hypool_ag-1 - ! Get total potential [Mpa] - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + i_up = j + i_lo = j+1 - ! Get Fraction of Total Conductivity [-] - ftc_node(i) = wkf_plant(p_media_nodes(i),ft)%p%ftc_from_psi(psi_node(i)) - ! deriv psi wrt theta - dpsi_dtheta_node(i) = wrf_plant(p_media_nodes(i),ft)%p%dpsidth_from_th(th_node(i)) + ! "Up" compartment is the "upper" node, but uses + ! the "lower" side of its compartment for the calculation. + ! Ultimately, it is more "upper" than its counterpart + ! This compartment is the "lower" node, but uses + ! the "higher" side of its compartment. - ! deriv ftc wrt psi + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) - dftc_dpsi = wkf_plant(p_media_nodes(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + end do - ! We have two ways to calculate radial absorbing root conductance - ! 1) Assume that water potential does not effect conductance - ! 2) The standard FTC function applies - - if(i==n_hypool_ag+2)then - if(no_ftc_radialk) then - ftc_node(i) = 1.0_r8 - dftc_dtheta_node(i) = 0.0_r8 + + ! Path is between lowest stem and transporting root + + j = n_hypool_ag + i_up = j + i_lo = j+1 + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between the transporting root + ! and the absorbing root for this layer + ! NOTE: No need to scale by root fraction + ! even if in parallel mode, already parallel! + + j = n_hypool_ag+1 + i_up = j + i_lo = j+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + j = n_hypool_ag+2 + i_up = j + i_lo = j+1 + + ! Special case. Maximum conductance depends on the + ! potential gradient. + if(h_node(i_up) < h_node(i_lo) ) then + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) + else + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) end if - end if - - end do - - ! Same updates as loop above, but for rhizosphere shells - - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) - dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) - dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) - end do - - - !-------------------------------------------------------------------------------- - ! Part 2. Effective conductances over the path-length and Flux terms - ! over the node-to-node paths - !-------------------------------------------------------------------------------- - - ! Path is between the leaf node and first stem node - ! ------------------------------------------------------------------------------- - - j = 1 - i_up = 1 - i_lo = 2 - kmax_up = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf - kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- - - do j=2,n_hypool_ag-1 - - i_up = j - i_lo = j+1 - - - ! "Up" compartment is the "upper" node, but uses - ! the "lower" side of its compartment for the calculation. - ! Ultimately, it is more "upper" than its counterpart - ! This compartment is the "lower" node, but uses - ! the "higher" side of its compartment. - - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - - ! Path is between lowest stem and transporting root - j = n_hypool_ag - i_up = j - i_lo = j+1 - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! Path is between the transporting root - ! and the absorbing root for this layer - ! NOTE: No need to scale by root fraction - ! even if in parallel mode, already parallel! + ! Path is between rhizosphere shells - j = n_hypool_ag+1 - i_up = j - i_lo = j+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - j = n_hypool_ag+2 - i_up = j - i_lo = j+1 - - ! Special case. Maximum conductance depends on the - ! potential gradient. - if(h_node(i_up) < h_node(i_lo) ) then - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) - else - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) - end if - - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between rhizosphere shells - - do j = n_hypool_ag+3,n_hypool_tot-1 - - i_up = j - i_lo = j+1 - ishell_up = i_up - (n_hypool_ag+2) - ishell_lo = i_lo - (n_hypool_ag+2) - - kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant - kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - end do - - ! ------------------------------------------------------------------------------- - ! Part 3. - ! Loop through nodes again, build matrix - ! ------------------------------------------------------------------------------- - - tris_a(1) = 0._r8 - tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep - tris_c(1) = B_term(1) - tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - - - do i = 2,n_hypool_tot-1 - j = i - tris_a(i) = -A_term(j-1) - tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = B_term(j) - tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & - k_eff(j-1)*(h_node(i)-h_node(i-1)) - - end do + print*,"THESE SHOULD BE THE SAME: ",(n_hypool_ag+2)-(n_hypool_tot-nshell) + stop - i = n_hypool_tot - j = n_hypool_tot - tris_a(i) = -A_term(j-1) - tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = 0._r8 - tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) + do j = n_hypool_ag+3,n_hypool_tot-1 + i_up = j + i_lo = j+1 + ishell_up = i_up - (n_hypool_tot-nshell) + ishell_lo = i_lo - (n_hypool_tot-nshell) - ! Calculate the change in theta + kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant + kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant - call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! If we have not broken from the substep loop, - ! that means this sub-step has been acceptable, and we may - ! go ahead and update the water content for the integrator - - th_node(:) = th_node(:) + dth_node(:) - - ! Mass error (flux - change) - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_end = sum(th_node(:)*v_node(:))*denh2o - - wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - - if(abs(wb_step_err)>max_wb_step_err)then - solution_found = .false. - error_code = 1 - error_arr(:) = 0._r8 - exit - else - ! Note: this is somewhat of a default true. And the sub-steps - ! will keep going unless its changed and broken out of - ! the loop. - solution_found = .true. - error_code = 0 - end if - - ! Extra checks - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if - - ! Calculate new psi for checks - do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) - end do - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - end do - - - ! We currently allow super-saturation, but draw the line - ! at 100% of volume... - if( any(th_node(:)>1.0_r8) ) then - solution_found = .false. - error_code = 2 - error_arr(:) = th_node(:) - exit - end if - - ! We dont allow any super-saturaiton in soil nodes - if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then - solution_found = .false. - error_code = 4 - error_arr(:) = th_node(:) - exit - end if - - - - ! Check if any psi values are > 0 - !if(any(psi_node(:) > nearzero)) then - ! solution_found = .false. - ! error_code = 4 - ! error_arr(:) = psi_node(:) - ! exit - !end if - - ! Accumulate the water balance error for diagnostic purposes - wb_err = wb_err + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - i = n_hypool_ag - sapflow = sapflow + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! Root uptake is the integrated flux between the first rhizosphere - ! shell and the absorbing root - - i = n_hypool_ag+2 - rootuptake = rootuptake + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! If debug mode is on, lets also track the mass fluxes across each - ! path, and keep a running average of the effective conductances - if(debug)then - do j=1,n_hypool_tot-1 - k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step - flux_diag(j) = flux_diag(j) + dt_substep * ( & - k_eff(j)*(h_node(j+1)-h_node(j)) + & - A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) - end do - end if - - end do ! do istep = 1,nsteps (substep loop) - - iter=iter+1 - - end do - - - ! ----------------------------------------------------------- - ! To a final check on water balance error sumed over sub-steps - ! ------------------------------------------------------------ - if ( abs(wb_err) > max_wb_err ) then - - write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' - - leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o - stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & - cohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & - sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end do + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- + + tris_a(1) = 0._r8 + tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep + tris_c(1) = B_term(1) + tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - ! Adjust final water balance by adding back in the error term - ! ------------------------------------------------------------ -!! if( abs(wb_err*cohort%n)*AREA_INV>1.0e-7_r8) then -!! if(debug) then -!! write(fates_log(),*)'WARNING: plant hydraulics water balance error exceeds 1.0e-7 and is ajusted for error' -!! endif -!! !dump the error water to the bin with largest water storage -!! max_l = maxloc(th_node(:)*v_node(:),dim=1) -!! th_node(max_l) = th_node(max_l)- & -!! wb_err/(v_node(max_l)*denh2o) -!! th_node(max_l) = min (th_node(max_l),& -!! ths_node(max_l)-small_theta_num) -!! th_node(max_l) = max(th_node(max_l),& -!! thr_node(max_l)+small_theta_num) -!! end if + do i = 2,n_hypool_tot-1 + j = i + tris_a(i) = -A_term(j-1) + tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = B_term(j) + tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & + k_eff(j-1)*(h_node(i)-h_node(i-1)) + end do + i = n_hypool_tot + j = n_hypool_tot + tris_a(i) = -A_term(j-1) + tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = 0._r8 + tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) - ! If we have made it to this point, supposedly we have completed the whole time-step - ! for this cohort x layer combination. It is now safe to save the delta theta - ! value and pass it back to the calling routine. The value passed back is the - ! change in theta over all sub-steps. - dth_node(:) = th_node(:)-th_node_init(:) + ! Calculate the change in theta + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) - ! Record the layer with the most iterations, but only - ! if it greater than 1. It will default to zero - ! if no layers took extra iterations. - if( (real(iter)>ccohort_hydr%iterh1) .and. (iter>1) )then - ccohort_hydr%iterlayer = real(j) + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator + + th_node(:) = th_node(:) + dth_node(:) + + ! Mass error (flux - change) + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) + + if(abs(wb_step_err)>max_wb_step_err)then + solution_found = .false. + error_code = 1 + error_arr(:) = 0._r8 + exit + else + ! Note: this is somewhat of a default true. And the sub-steps + ! will keep going unless its changed and broken out of + ! the loop. + solution_found = .true. + error_code = 0 end if - ! Save the number of times we refined our sub-step counts (iterh1) - ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) - ! Save the number of sub-steps we ultimately used - ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) - - ! Update water contents in the relevant plant compartments [m3/m3] - - ! Leaf and above-ground stems - ccohort_hydr%th_ag(1:n_hypool_ag) = ccohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - ! Transporting root - ccohort_hydr%th_troot = ccohort_hydr%th_troot + dth_node(n_hypool_ag+1) - ! Absorbing root - ccohort_hydr%th_aroot(j) = ccohort_hydr%th_aroot(j) + dth_node(n_hypool_ag+2) - + ! Extra checks + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if - ! Change in water per plant [kg/plant] - dwat_veg_coh = & - (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(j))*denh2o + ! Calculate new psi for checks + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) + end do + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + end do - ! Accumulate site level diagnosti of plant water change - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV + ! We currently allow super-saturation, but draw the line + ! at 100% of volume... + if( any(th_node(:)>1.0_r8) ) then + solution_found = .false. + error_code = 2 + error_arr(:) = th_node(:) + exit + end if - ! Update total site-level stored plant water - site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV + ! We accept that it is possible for gravity to push + ! water into saturated soils, particularly at night when + ! transpiration has stopped. In the real world, the water + ! would be driven out of the layer, although we have no + ! boundary flux on the rhizospheres in these substeps. To accomodate + ! this, if soils are pushed beyond saturation minus a small buffer + ! then we remove that excess, send it to a runoff pool, and + ! fix the node's water content to the saturation minus buffer value - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_error - - ! Update total error in [kg/m2 ground] - ! (RGK: should this be + wb_error*ccohort%n/ccohort%c_area ??? - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_error*ccohort%c_area*AREA_INV + do i = 1,nshell + ishell = n_hypool_tot-nshell+i + if(th_node(ishell)>(bc_in%watsat_sisl(ilayer)-thsat_buff)) then + ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] + runoff = runoff + & + (th_node(ishell)-(bc_in%watsat_sisl(ilayer)-thsat_buff)) * & + v_node(ishell)*AREA_INV - ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow - ccohort_hydr%rootuptake(j) = ccohort_hydr%rootuptake(j) + rootuptake - - ! Save the change in water mass in the rhizosphere. Note that we did - ! not immediately update the state variables upon completing each - ! plant-layer solve. We accumulate the difference, and apply them - ! after all cohort-layers are complete. This allows each cohort - ! to experience the same water conditions (for good or bad). + th_node(ishell) = (bc_in%watsat_sisl(ilayer)-thsat_buff + end if + end do - if(site_hydr%l_aroot_layer(j)bc_in%watsat_sisl(ilayer)) ) then + ! solution_found = .false. + ! error_code = 4 + ! error_arr(:) = th_node(:) + ! exit + !end if + + ! Check if any psi values are > 0 + !if(any(psi_node(:) > nearzero)) then + ! solution_found = .false. + ! error_code = 4 + ! error_arr(:) = psi_node(:) + ! exit + !end if + + ! Accumulate the water balance error of the layer over the sub-steps + ! for diagnostic purposes + ! [kg/m2] + wb_err_layer = wb_err_layer + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + i = n_hypool_ag + sapflow = sapflow + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + i = n_hypool_ag+2 + rootuptake = rootuptake + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! If debug mode is on, lets also track the mass fluxes across each + ! path, and keep a running average of the effective conductances + if(debug)then + do j=1,n_hypool_tot-1 + k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step + flux_diag(j) = flux_diag(j) + dt_substep * ( & + k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) + end do end if + + end do ! do istep = 1,nsteps (substep loop) - dth_layershell_col(j,:) = dth_layershell_col(j,:) + & - dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & - ccohort_hydr%l_aroot_layer(j) * & - ccohort%n / site_hydr%l_aroot_layer(j) - + iter=iter+1 + + end do + + ! ----------------------------------------------------------- + ! Do a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err_layer) > max_wb_err ) then + + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' + + leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o + stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & + cohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & + sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o + + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! If we have made it to this point, supposedly we have completed the whole time-step + ! for this cohort x layer combination. It is now safe to save the delta theta + ! value and pass it back to the calling routine. The value passed back is the + ! change in theta over all sub-steps. + + dth_node(:) = th_node(:)-th_node_init(:) + + + ! Record the layer with the most iterations, but only + ! if it greater than 1. It will default to zero + ! if no layers took extra iterations. + if( (real(iter)>ccohort_hydr%iterh1) .and. (iter>1) )then + ccohort_hydr%iterlayer = real(ilayer) + end if + + ! Save the number of times we refined our sub-step counts (iterh1) + ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) + ! Save the number of sub-steps we ultimately used + ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) + + ! Update water contents in the relevant plant compartments [m3/m3] + ! ------------------------------------------------------------------------------- + + ! Leaf and above-ground stems + ccohort_hydr%th_ag(1:n_hypool_ag) = ccohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + ! Transporting root + ccohort_hydr%th_troot = ccohort_hydr%th_troot + dth_node(n_hypool_ag+1) + ! Absorbing root + ccohort_hydr%th_aroot(ilayer) = ccohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) + + ! Change in water per plant [kg/plant] + dwat_veg_coh = & + (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & + dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(ilayer))*denh2o + + ! Accumulate site level diagnostic of plant water change [kg/m2] + ! (this is zerod) + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV + + ! Update total site-level stored plant water [kg/m2] + ! (this is not zerod, but incremented) + site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_layer + + ! Update total error in [kg/m2 ground] + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_layer*ccohort%n*AREA_INV + + ! This is same as above, but just for the current time-step + ! used for mass balance checking [kg/m2] + wb_err_site = wb_err_site + wb_err_layer*ccohort%n*AREA_INV + + + ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow + ccohort_hydr%rootuptake(ilayer) = ccohort_hydr%rootuptake(ilayer) + rootuptake + + ! Save the change in water mass in the rhizosphere. Note that we did + ! not immediately update the state variables upon completing each + ! plant-layer solve. We accumulate the difference, and apply them + ! after all cohort-layers are complete. This allows each cohort + ! to experience the same water conditions (for good or bad). + + if(site_hydr%l_aroot_layer(ilayer) ilayer) return diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 81ad0975e9..cd7c8b0143 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -9,7 +9,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .true. + logical, parameter, public :: use_2d_hydrosolve = .false. ! Number of soil layers for indexing cohort fine root quanitities @@ -103,7 +103,7 @@ module FatesHydraulicsMemMod ! defined at the end of the hydraulics sequence ! after root water has been extracted. This should ! be equal to the sum of the water over the rhizosphere shells - + ! [kg/m2] real(r8),allocatable :: recruit_w_uptake(:) ! recruitment water uptake (kg H2o/m2/s) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index aaf392048b..c57a474680 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -567,7 +567,12 @@ module FatesInterfaceMod real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer ! [mm H2O/s] [+ into root] - + real(r8),allocatable :: qflx_ro_si ! Water flux from runoff generated by + ! either plant hydraulics or dynamics + ! [mm H2O/s] + ! In hydraulics this is possible due to super-saturation + ! in dynamics this is possible due to the release of water + ! from plant death and litter drop end type bc_out_type @@ -974,6 +979,7 @@ subroutine zero_bcs(this,s) this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 end if this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 + this%bc_out(s)%qflx_ro_si = 0.0_r8 return end subroutine zero_bcs From 5dbc71a236aa95d0f3e9870ea26d0a4bb20e54d5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Jan 2020 11:58:57 -0800 Subject: [PATCH 048/114] Refactoring 2D matrix solve for hydro --- biogeophys/FatesPlantHydraulicsMod.F90 | 140 +++++++++++++++++-------- main/FatesHydraulicsMemMod.F90 | 8 +- 2 files changed, 105 insertions(+), 43 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 9e597af65c..fffe36f8b4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2441,7 +2441,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & ! dtime,qflx_tran_veg_indiv, & - ! sapflow,rootuptake,wb_error_site,iter,nsteps) + ! sapflow,rootuptake,wb_error_site,nsteps, & + ! dth_layershell_col,site_runoff) else @@ -4391,22 +4392,38 @@ end subroutine boundary_hdiff_and_k_alt ! ===================================================================================== - subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_hydr, & - bc_in,dth_layershell,sapflow) + subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & + dtime,qtop, & + sapflow,rootuptake,wb_error_site, nsteps, & + dth_layershell_site, runoff_site) use EDTypesMod , only : AREA ! ARGUMENTS: ! ----------------------------------------------------------------------------------- type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(ed_cohort_hydr_type), target :: ccohort_hydr - type(ed_cohort_type) , intent(inout), target :: cohort - type(bc_in_type),intent(in) :: bc_in + type(ed_cohort_hydr_type), target :: ccohort_hydr + type(ed_cohort_type) , intent(inout), target :: cohort + type(bc_in_type),intent(in) :: bc_in + real(r8),intent(in) :: dtime + real(r8),intent(in) :: qtop + real(r8),intent(out) :: sapwflow + real(r8),intent(out) :: rootuptake + integer,intent(out) :: nsteps + real(r8),intent(inout) :: wb_error_site + real(r8),intent(inout) :: dth_layershell_site + real(r8),intent(inout) :: runoff_site + + integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol integer :: j, icnx, pmx,inewt integer :: id_dn, id_up real(r8) :: psisat,B,thsat,psi_pt,tmp real(r8) :: values(4) + + + ! Move these to site-level scratch space + ! real(r8) :: residual(num_nodes) real(r8) :: ajac(num_nodes,num_nodes) real(r8) :: dth_node(num_nodes) @@ -4416,13 +4433,16 @@ subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_h real(r8) :: psi_node(num_nodes) real(r8) :: k_bound(num_connections) real(r8) :: hdiff_bound(num_connections) - real(r8) :: hdiffx, k_boundx, dkdpsix real(r8) :: dhdpsi(num_connections,2) real(r8) :: dkdpsi(num_connections,2) + real(r8) :: q_flux(num_connections) + + real(r8) :: hdiffx, k_boundx, dkdpsix + real(r8) :: dt_time real(r8) :: dnr, thx, thx_pt real(r8) :: qflx - real(r8) :: q_flux(num_connections) + real(r8) :: qtop, dqflx_dn, dqflx_up !qtop - flux from canopy, kgh2o indiv-1 s-1 real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] real(r8) :: dflcgsdth ! derivative of stomatal vuln curve wrt to leaf water content [m-3 m3] @@ -4436,7 +4456,6 @@ subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_h real(r8) :: blux(num_nodes) integer :: indices(num_nodes) real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: flc_min_node( n_hypool_tot-nshell) ! minimum attained fractional loss of conductivity (for xylem refilling dynamics)[-] real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] real(r8) :: dflcdpsi_node(num_nodes) ! derivative of fractional loss of conductivity wrt psi [MPa-1] @@ -4478,43 +4497,86 @@ subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_h nstep = get_nstep() - associate( & - z_lower_ag => ccohort_hydr%z_lower_ag, & - z_upper_ag => ccohort_hydr%z_upper_ag, & - z_node_ag => ccohort_hydr%z_node_ag, & - z_node => ccohort_hydr%z_node, & - v_node => ccohort_hydr%v_node, & - conn_up => ccohort_hydr%conn_up, & - conn_dn => ccohort_hydr%conn_dn, & - cond_up => ccohort_hydr%cond_up, & - cond_dn => ccohort_hydr%cond_dn, & - conductance => ccohort_hydr%conductance, & - th_node_init => ccohort_hydr%th_node_init, & - th_node => ccohort_hydr%th_node, & - psi_node_init => ccohort_hydr%psi_node_init, & - psi_node => ccohort_hydr%psi_node, & - pm_type => ccohort_hydr%pm_type & - ) +! associate( & +! z_lower_ag => ccohort_hydr%z_lower_ag, & +! z_upper_ag => ccohort_hydr%z_upper_ag, & +! z_node_ag => ccohort_hydr%z_node_ag, & +! z_node => ccohort_hydr%z_node, & +! v_node => ccohort_hydr%v_node, & +! conn_up => ccohort_hydr%conn_up, & +! conn_dn => ccohort_hydr%conn_dn, & +! cond_up => ccohort_hydr%cond_up, & +! cond_dn => ccohort_hydr%cond_dn, & +! conductance => ccohort_hydr%conductance, & +! th_node_init => ccohort_hydr%th_node_init, & +! th_node => ccohort_hydr%th_node, & +! psi_node_init => ccohort_hydr%psi_node_init, & +! psi_node => ccohort_hydr%psi_node, & +! pm_type => ccohort_hydr%pm_type & +! ) + + associate(conn_up => site_hydr%conn_up, & + conn_dn => site_hydr%conn_dn ) + + ! Transfer node heights, volumes and initial water contents for + ! the transporting root and above ground compartments to the + ! complete node vector + + do i = 1,n_hypool_ag+n_hypool_troot + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i>n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + end if + end do + + ! Transfer node-heights, volumes and intiial water contents + ! for below-ground components, + ! from the cohort structures, into the complete node vector + inode = n_hypool_ag + n_hypool_troot + do j = 1,site_hydr%nlevsoi_hyd + + ! Calculate the fraction of the soil layer + ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot + inode = inode + 1 + if (k flc_min_node(k)) then - dflcdpsi_node(k) = 0._r8 - flc_node(k) = flc_min_node(k) - end if - end if enddo num_nds = n_hypool_ag + n_hypool_troot @@ -4530,12 +4592,6 @@ subroutine Hydraulics_alt_1DSolve(dtime, s, cohort,ft, qtop, site_hydr,ccohort_h call dflcdpsi_from_psi(ft, pm_type(num_nds),psi_node_1l(k), dflcdpsi_node_1l(k), site_hydr, bc_in) if(k == n_hypool_ag + n_hypool_troot + 1) then - if(do_dyn_xylemrefill .and. porous_media(k) <= 4) then - if(flc_node_1l(k) > ccohort_hydr%flc_min_aroot(j)) then - dflcdpsi_node_1l(num_nds) = 0._r8 - flc_node_1l(num_nds) = ccohort_hydr%flc_min_aroot(j) - end if - end if flc_node(num_nds) = flc_node_1l(k) dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) else diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index cd7c8b0143..4812a884dd 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -143,7 +143,13 @@ module FatesHydraulicsMemMod integer, parameter, public :: num_connections integer, allocatable, public, protected :: conn_up(:) integer, allocatable, public, protected :: conn_dn(:) - integer, allocatable, public, protected :: pm_type(:) + + + + + + +! integer, allocatable, public, protected :: pm_type(:) contains From 5c9f6a58b47419bf52c4cee2fb02977f228a4c2d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 21 Jan 2020 09:54:05 -0800 Subject: [PATCH 049/114] Refactors of the matrix-newton solve of plant hydraulics. --- biogeophys/FatesPlantHydraulicsMod.F90 | 313 +++++++++++++++---------- 1 file changed, 184 insertions(+), 129 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index fffe36f8b4..b250a1d995 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4416,11 +4416,16 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol - integer :: j, icnx, pmx,inewt + integer :: j, icnx, pmx integer :: id_dn, id_up real(r8) :: psisat,B,thsat,psi_pt,tmp real(r8) :: values(4) + real(r8) :: wb_step_err ! water balance error over substep [kg] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + real(r8) :: dt_substep ! timestep length of substeps [s] + ! Move these to site-level scratch space ! @@ -4453,7 +4458,6 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & integer :: s integer :: num_nds real(r8) :: blu(num_nodes) - real(r8) :: blux(num_nodes) integer :: indices(num_nodes) real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] @@ -4464,22 +4468,39 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] real(r8) :: hdiff_bound_1l( nshell+1) ! - real(r8) :: dth_layershell(nlevsoi_hyd_max,nshell) ! accumulated water content change over a cohort in a column [m3 m-3] - integer :: icnv + + + + integer :: icnv ! Convergence flag for each solve + ! icnv = 1 convergence failure, B vector may have NANs + ! icnv = 2 solution is not yet in-balance, keep trying + ! icnv = 3 acceptable solution + ! icnv = 4 too many failures, not converging + + real(r8) :: thsatx real(r8) :: slx real(r8) :: plx real(r8) :: dplx - real(r8) :: rsd, rsdx, rlfx, rlfx1, rsdp + real(r8) :: residual_amax ! maximum absolute mass balance residual over all + ! nodes, + ! used for determining convergence. At the point + + real(r8) :: rsdx ! Temporary residual while determining max value + + + real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments + real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents + + real(r8) :: acp real(r8) :: dcomp real(r8) :: dtime, dtx, dtcf, tm, dto, dtimex, var, varx, tmx,dtime_o real(r8) :: dwat_veg_coh - integer :: nsd + integer :: nsd ! node index in B vector with highest term integer :: niter integer :: ntsr - integer :: n_hypool_at - integer :: ksh + integer :: kshell ! rhizosphere shell index, 1->nshell integer :: outer_nodes(10) integer :: bc_cnx(10) real(r8) :: smp, h2osoi_liqvol @@ -4496,25 +4517,6 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & !for debug only nstep = get_nstep() - -! associate( & -! z_lower_ag => ccohort_hydr%z_lower_ag, & -! z_upper_ag => ccohort_hydr%z_upper_ag, & -! z_node_ag => ccohort_hydr%z_node_ag, & -! z_node => ccohort_hydr%z_node, & -! v_node => ccohort_hydr%v_node, & -! conn_up => ccohort_hydr%conn_up, & -! conn_dn => ccohort_hydr%conn_dn, & -! cond_up => ccohort_hydr%cond_up, & -! cond_dn => ccohort_hydr%cond_dn, & -! conductance => ccohort_hydr%conductance, & -! th_node_init => ccohort_hydr%th_node_init, & -! th_node => ccohort_hydr%th_node, & -! psi_node_init => ccohort_hydr%psi_node_init, & -! psi_node => ccohort_hydr%psi_node, & -! pm_type => ccohort_hydr%pm_type & -! ) - associate(conn_up => site_hydr%conn_up, & conn_dn => site_hydr%conn_dn ) @@ -4554,91 +4556,58 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & v_node(inode) = cohort_hydr%v_aroot_layer(j) th_node_init(inode) = cohort_hydr%th_aroot(j) else - ishell = k-(n_hypool_tot-nshell) + kshell = k-(n_hypool_tot-nshell) z_node(inode) = -bc_in%z_sisl(j) ! The volume of the Rhizosphere for a single plant - v_node(inode) = site_hydr%v_shell(j,ishell)*aroot_frac_plant - th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(j,ishell) + v_node(inode) = site_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(j,kshell) end if enddo enddo - - - - - ! assign variables - th_node( 1 : n_hypool_ag ) =ccohort_hydr%th_ag(:) - th_node( (n_hypool_ag+1):(n_hypool_ag+n_hypool_troot)) =ccohort_hydr%th_troot(:) - - do k = 1, n_hypool_ag+n_hypool_troot - call psi_from_th(ft, porous_media(k), th_node(k), psi_node(k),site_hydr, bc_in) - call dpsidth_from_th(ft, porous_media(k), th_node(k),dpsidth_node(k), site_hydr, bc_in) - call flc_from_psi(ft, porous_media(k), psi_node(k), flc_node(k),site_hydr, bc_in) - call dflcdpsi_from_psi(ft, porous_media(k), psi_node(k),dflcdpsi_node(k), site_hydr, bc_in) - enddo - num_nds = n_hypool_ag + n_hypool_troot + ! Initialize variables and flags that track + ! the progress of the solve - do j = 1,site_hydr%nlevsoi_hyd - th_node_1l((n_hypool_ag+n_hypool_troot+1)) = ccohort_hydr%th_aroot(j) - th_node_1l((n_hypool_ag+n_hypool_troot+2):(n_hypool_tot)) = site_hydr%h2osoi_liqvol_shell(j,:) + tmx = dtime + dtime_o = dtime + tm = 0 + ntsr = 0 - do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - num_nds = num_nds + 1 - call psi_from_th(ft, pm_type(num_nds), th_node_1l(k),psi_node_1l(k),site_hydr, bc_in) - call flc_from_psi(ft, pm_type(num_nds),psi_node_1l(k), flc_node_1l(k), site_hydr, bc_in) - call dflcdpsi_from_psi(ft, pm_type(num_nds),psi_node_1l(k), dflcdpsi_node_1l(k), site_hydr, bc_in) - - if(k == n_hypool_ag + n_hypool_troot + 1) then - flc_node(num_nds) = flc_node_1l(k) - dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) - else - flc_node(num_nds) = flc_node_1l(k) - dflcdpsi_node(num_nds) = dflcdpsi_node_1l(k) - if(k==n_hypool_tot) outer_nodes(j) = num_nds - endif - psi_node(num_nds) = psi_node_1l(k) - th_node(num_nds) = th_node_1l(k) - enddo - enddo - th_node_init(:) = th_node(:) - psi_node_init(:) = psi_node(:) - ! - nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot - ! - rlfx = 1._r8 - rlfx1 = 0.15_r8 - rsdp = 0._r8 - inewt = 0 - tmx = dtime - dtime_o = dtime - tm = 0 - ntsr = 0 - dth_layershell(:,:) = 0._r8 do while(tm < tmx) - rlfx = 0.6_r8 - !rlfx1 = 0.15_r8 - rlfx1 = 0.1_r8 - rsdp = 0._r8 - inewt = 0 + + rlfx_plnt = 0.6_r8 + rlfx_soil = 0.1_r8 + + ! Return here if there were NaN's or + ! problems reaching any iterator. It is + ! likely that the elapsed time through the step + ! was reset (tm) and the sub-step length (dtime) + ! was decreased. 100 continue + tm = tm + dtime niter = 0 itshk = 0 e0(:) = 0 e1(:) = 0 e2(:) = 0 + + + ! Return here if you are just continuing the + ! Newton search for a solution. No need to + ! update timing information, yet. 200 continue + niter = niter + 1 + !zero matrix and residual - if(inewt == 0) then - ajac(:,:) = 0._r8 - endif + ajac(:,:) = 0._r8 residual(:) = 0._r8 - blu(:) = 0._r8 + blu(:) = 0._r8 + ! do k = 1, num_nodes call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) @@ -4663,14 +4632,14 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! dnr = -0.005*abs(psi_node(k)) - 1e-12 dnr = -1.e-8_r8 ! dnr = -max(1.e-6,0.05*abs(psi_node(k))) - if(pm_type(k) <= nt_ab) then + if(pm_type(k) <= n_hypool_plant) then call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) ! incremented psi psi_pt = psi_node(k) + dnr call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr else - j = pm_type(k)-nt_ab + j = pm_type(k)-n_hypool_plant B = bc_in%bsw_sisl(j) psisat = bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8 !! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa thsat = bc_in%watsat_sisl(j) @@ -4682,10 +4651,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & endif values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp endif - if(inewt == 0) then - ! call MatSetValues( fmat,nr,ir(1),nc,ic(1),values(1),ADD_VALUES,ierr ) - ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) - end if + + ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) + enddo ! calculate boundary fluxes @@ -4712,11 +4680,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & values(2) = -dqflx_up values(3) = dqflx_dn values(4) = dqflx_up - if(inewt == 0) then - ! call MatSetValues( fmat,nr,ir,nc,ic,values,ADD_VALUES,ierr ) - ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) - ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) - end if + + ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) + ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) + enddo ! residual(1) = residual(1) + qtop @@ -4725,11 +4692,15 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & icnv = 3 - ! CALL DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) - ! check residual - !if(nstep==15764) print *,'ft,it,rsd-',ft,niter,rsd,'qtop',qtop,psi_node,'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node - rsd = 0._r8 + ! if(nstep==15764) print *,'ft,it,residual_amax-',ft,niter,residual_amax,'qtop',qtop,psi_node, + ! 'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node + + ! Residual at this point, is the RHS of the matrix equation. In this next + ! step we are simply identifying if these terms are finite and how + ! large the largest one is. + + residual_amax = 0._r8 nsd = 0 do k = 1, num_nodes rsdx = abs(residual(k)) @@ -4738,21 +4709,73 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & icnv = 1 exit endif - if( rsdx > rsd ) then - rsd = rsdx + if( rsdx > residual_amax ) then + residual_amax = rsdx nsd = k endif enddo - ! matrix no update if inewt = 1 - ! if( niter > 100 .and. rsd < 1.e-1) inewt = 1 + if(icnv == 1) goto 199 - rsdp = rsd - ! check convergence - if( rsd > 1.e-8_r8 ) then - icnv = 2 - info = 0 + + ! If the solution is balanced, none of the residuals + ! should be very large, and we can ignore another + ! solve attempt. + + if( residual_amax > 1.e-8_r8 ) then + icnv = 2 + + ! --------------------------------------------------------------------------- + ! From Lapack documentation + ! + ! subroutine dgesv(integer N, + ! integer NRHS, + ! real(r8), dimension( lda, * ) A, + ! integer LDA, + ! integer, dimension( * ) IPIV, + ! real(r8), dimension( ldb, * ) B, + ! integer LDB, + ! integer INFO ) + ! + ! DGESV computes the solution to a real system of linear equations + ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. + ! The LU decomposition with partial pivoting and row interchanges is + ! used to factor A as A = P * L * U, + ! where P is a permutation matrix, L is unit lower triangular, and U is + ! upper triangular. The factored form of A is then used to solve the + ! system of equations A * X = B. + ! + ! N is the number of linear equations, i.e., the order of the + ! matrix A. N >= 0. + ! + ! NRHS is the number of right hand sides, i.e., the number of columns + ! of the matrix B. NRHS >= 0. + ! + ! A: + ! On entry, the N-by-N coefficient matrix A. + ! On exit, the factors L and U from the factorization + ! A = P*L*U; the unit diagonal elements of L are not stored. + ! + ! LDA is the leading dimension of the array A. LDA >= max(1,N). + ! + ! IPIV is the pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + ! + ! B + ! On entry, the N-by-NRHS matrix of right hand side matrix B. + ! On exit, if INFO = 0, the N-by-NRHS solution matrix X. + ! + ! LDB is the leading dimension of the array B. LDB >= max(1,N). + ! + ! INFO: + ! = 0: successful exit + ! < 0: if INFO = -i, the i-th argument had an illegal value + ! > 0: if INFO = i, U(i,i) is exactly zero. The factorization + ! has been completed, but the factor U is exactly + ! singular, so the solution could not be computed. + ! --------------------------------------------------------------------------- + call DGESV(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) if ( info == -1 ) then @@ -4769,12 +4792,12 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & !if(abs(blu(k))> abs(psi_node(k))) then ! psi_node(k) = psi_node(k) + blu(k)*rlfx1*0.5 !else - psi_node(k) = psi_node(k) + blu(k)*rlfx1 + psi_node(k) = psi_node(k) + blu(k)*rlfx_soil !endif else ! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx - psi_node(k) = psi_node(k) + blu(k) * rlfx + psi_node(k) = psi_node(k) + blu(k) * rlfx_plnt endif enddo @@ -4783,14 +4806,16 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & icnv = 1 endif if(niter > 500) then - rlfx = 0.4_r8 - rlfx1 = 0.1_r8 + rlfx_plnt = 0.4_r8 + rlfx_soil = 0.1_r8 end if + 199 continue + if( icnv == 1 ) then write(*,'(10x,a)') '--- Convergence Failure ---' write(*,'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & - rsd,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) + residual_amax,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) if( ntsr < 10 ) then tm = tm - dtime ntsr = ntsr + 1 @@ -4808,8 +4833,8 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & psi_node(k) = psi_node_init(k) th_node(k) = th_node_init(k) enddo - rlfx = 0.6_r8 - rlfx1 = 0.15_r8 + rlfx_plnt = 0.6_r8 + rlfx_soil = 0.15_r8 ! !--- Number of time step reductions failure: stop simulation --- ! @@ -4834,6 +4859,12 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! enddo 201 continue + + ! If we have reached this point, we have iterated to + ! a stable solution (where residual mass balance = 0) + ! It is possible that we have used a sub-step though, + ! and need to continue the iteration. + ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) @@ -4842,21 +4873,30 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) num_nds = n_hypool_ag+n_hypool_troot - n_hypool_at = n_hypool_ag + n_hypool_troot + 1 + + do j = 1,site_hydr%nlevsoi_hyd do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot num_nds = num_nds + 1 - if(k==n_hypool_at) then + if(k==n_hypool_plant) then ccohort_hydr%th_aroot(j) = th_node(num_nds) ccohort_hydr%psi_aroot(j) = psi_node(num_nds) ccohort_hydr%flc_aroot(j) = flc_node(num_nds) dwat_veg_coh = dwat_veg_coh + dth_node(num_nds) * v_node(num_nds) else - ksh = k-n_hypool_at - dth_layershell(j,ksh) = dth_layershell(j,ksh) + & - (th_node(num_nds) - th_node_init(num_nds)) * & - ccohort_hydr%l_aroot_layer(j) * & - ccohort%n /site_hydr%l_aroot_layer(j) * dtime +! kshell = k-n_hypool_plant +! dth_layershell(j,kshell) = dth_layershell(j,kshell) + & +! (th_node(num_nds) - th_node_init(num_nds)) * & +! ccohort_hydr%l_aroot_layer(j) * & +! ccohort%n /site_hydr%l_aroot_layer(j) * dtime + + + !dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & + ! dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & + ! ccohort_hydr%l_aroot_layer(ilayer) * & + ! ccohort%n / site_hydr%l_aroot_layer(ilayer) + + endif enddo enddo @@ -4866,11 +4906,26 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & th_node_init(:) = th_node(:) psi_node_init(:) = psi_node(:) enddo - dth_layershell(:,:) = dth_layershell(:,:) / dtime_o + + + ! Assign the changes to the site level soil water + do j = 1,site_hydr%nlevsoi_hyd + do k = n_hypool_plant+1, n_hypool_tot + inode = inode + 1 + kshell = k-n_hypool_plant + + dth_layershell(j,kshell) = dth_layershell(j,kshell) + & + (th_node(inode) - th_node_init(inode)) * & + ccohort_hydr%l_aroot_layer(j) * & + ccohort%n /site_hydr%l_aroot_layer(j) + + end do + end do + end associate return - end subroutine hydraulics_alt_1DSolve + end subroutine MatSolve2D ! ===================================================================================== From 40c1b353e6d3c92d785e2f327431ef4db20e088a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 22 Jan 2020 11:29:37 -0800 Subject: [PATCH 050/114] More refactors towards newton-matrix plant hydraulics solve. --- biogeophys/FatesPlantHydraulicsMod.F90 | 151 ++++++++++++++++++------- 1 file changed, 112 insertions(+), 39 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index b250a1d995..4662d4b0e8 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -3875,27 +3875,71 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & ! themselves, but to the path between the nodes, defined as positive ! direction from "up"per (closer to atm) and "lo"wer (further from atm). ! ----------------------------------------------------------------------------- - + ! Arguments real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8) :: ftc_lo, ftc_up ! frac total conductance [-] + real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] - real(r8) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative + real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative ! of FTC wrt relative water content real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential ! wrt relative water content - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] real(r8),intent(out) :: a_term ! "A" term for path (See tech note) real(r8),intent(out) :: b_term ! "B" term for path (See tech note) + + ! Locals real(r8) :: h_diff ! Total potential difference [MPa] - logical, parameter :: do_upstream_k = .true. ! the effective fraction of total - ! conductivity is either governed - ! by the upstream node, or by both - ! with a harmonic average ! Calculate difference in total potential over the path [MPa] h_diff = h_lo - h_up + ! "A" term, which operates on the upper node (closer to atm) + a_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + * dftc_dtheta_up - k_eff * dpsi_dtheta_up + + + ! "B" term, which operates on the lower node (further from atm) + b_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & + * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo + + + + return + end subroutine GetImTaylorKAB + + ! ===================================================================================== + + subroutine GetEffKFTC(kmax_lo,kmax_up, & + h_lo,h_up, & + ftc_lo,ftc_up, & + dftc_dtheta_lo, dftc_dtheta_up, & + k_eff) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction from "up"per (closer to atm) and "lo"wer (further from atm). + ! ----------------------------------------------------------------------------- + + real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] + real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] + real(r8),intent(inout) :: ftc_lo, ftc_up ! frac total conductance [-] + real(r8),intent(inout) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative + ! of FTC wrt relative water content + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + + ! Locals + real(r8) :: h_diff ! Total potential difference [MPa] + logical, parameter :: do_upstream_k = .true. ! the effective fraction of total + ! conductivity is either governed + ! by the upstream node, or by both + ! with a harmonic average + ! Calculate difference in total potential over the path [MPa] + h_diff = h_lo - h_up ! If we do enable "upstream K", then we are saying that ! the fractional loss of conductivity is dictated @@ -3918,21 +3962,10 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & ! Calculate total effective conductance over path [kg s-1 MPa-1] k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_lo*kmax_lo)) - - ! "A" term, which operates on the upper node (closer to atm) - a_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & - * dftc_dtheta_up - k_eff * dpsi_dtheta_up - - - ! "B" term, which operates on the lower node (further from atm) - b_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & - * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo - - return - end subroutine GetImTaylorKAB - + end subroutine GetEffKFTC + subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) @@ -4429,18 +4462,18 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! Move these to site-level scratch space ! - real(r8) :: residual(num_nodes) - real(r8) :: ajac(num_nodes,num_nodes) - real(r8) :: dth_node(num_nodes) - real(r8) :: th_node_init(num_nodes) - real(r8) :: psi_node_init(num_nodes) - real(r8) :: th_node(num_nodes) - real(r8) :: psi_node(num_nodes) - real(r8) :: k_bound(num_connections) - real(r8) :: hdiff_bound(num_connections) - real(r8) :: dhdpsi(num_connections,2) - real(r8) :: dkdpsi(num_connections,2) - real(r8) :: q_flux(num_connections) +! real(r8) :: residual(num_nodes) +! real(r8) :: ajac(num_nodes,num_nodes) +! real(r8) :: dth_node(num_nodes) +! real(r8) :: th_node_init(num_nodes) +! real(r8) :: psi_node_init(num_nodes) +! real(r8) :: th_node(num_nodes) +! real(r8) :: psi_node(num_nodes) +! real(r8) :: k_bound(num_connections) +! real(r8) :: hdiff_bound(num_connections) +! real(r8) :: dhdpsi(num_connections,2) +! real(r8) :: dkdpsi(num_connections,2) +! real(r8) :: q_flux(num_connections) real(r8) :: hdiffx, k_boundx, dkdpsix @@ -4586,8 +4619,20 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! likely that the elapsed time through the step ! was reset (tm) and the sub-step length (dtime) ! was decreased. + + + 100 continue + + ! Set the current water content as the initial [m3/m3] + th_node(:) = th_node_init(:) + do k=1,num_nodes + ! Get matric potential [Mpa] + psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) + end do + + tm = tm + dtime niter = 0 itshk = 0 @@ -4595,7 +4640,6 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & e1(:) = 0 e2(:) = 0 - ! Return here if you are just continuing the ! Newton search for a solution. No need to ! update timing information, yet. @@ -4609,16 +4653,41 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & blu(:) = 0._r8 ! - do k = 1, num_nodes - call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) - call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) - enddo +! do k = 1, num_nodes +! call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) +! call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) +! enddo - call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) +! call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) do k=1,num_nodes + ! residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(p_media_nodes(k),ft)%p%ftc_from_psi(psi_node(k)) + + ! deriv psi wrt theta + dpsi_dtheta_node(k) = wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k)) + + ! deriv ftc wrt psi + + dftc_dpsi = wkf_plant(p_media_nodes(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi * dpsi_dtheta_node(k) + + ! This will get the effective K, and may modify FTC depending + ! on the flow direction + + call GetEffKFTC(kmax_lo,kmax_up,h_lo,h_up,ftc_lo,ftc_up, & + dftc_dtheta_lo, dftc_dtheta_up, k_eff) + + + ! matrix ic(:) = 0 ir(:) = 0 @@ -4652,6 +4721,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp endif + + values(1) = + + ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) enddo From c5c93a5e4aa34d30c7d0b5997f1ae0a2336ae56a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 22 Jan 2020 15:19:26 -0800 Subject: [PATCH 051/114] Partial addition of site-level hydraulics scratch spaces. --- biogeophys/FatesPlantHydraulicsMod.F90 | 18 ++++++----- main/FatesHydraulicsMemMod.F90 | 45 ++++++++++++++++++++++---- 2 files changed, 49 insertions(+), 14 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 4662d4b0e8..ff53601af4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4468,7 +4468,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! real(r8) :: th_node_init(num_nodes) ! real(r8) :: psi_node_init(num_nodes) ! real(r8) :: th_node(num_nodes) -! real(r8) :: psi_node(num_nodes) +! real(r8) :: psi_node(num_nodes) +! real(r8) :: blu(num_nodes) +! integer :: indices(num_nodes) ! real(r8) :: k_bound(num_connections) ! real(r8) :: hdiff_bound(num_connections) ! real(r8) :: dhdpsi(num_connections,2) @@ -4490,8 +4492,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8) :: qscale integer :: s integer :: num_nds - real(r8) :: blu(num_nodes) - integer :: indices(num_nodes) + + + ! Probably will remove these real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] @@ -4499,7 +4502,6 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] - real(r8) :: hdiff_bound_1l( nshell+1) ! @@ -4938,10 +4940,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! It is possible that we have used a sub-step though, ! and need to continue the iteration. - ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) - ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) - ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) - ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) + ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) + ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) + ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) + ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) ccohort_hydr%psi_troot(1:n_hypool_troot) = psi_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 4812a884dd..fc8cfa0702 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -386,16 +386,49 @@ subroutine InitHydrSite(this) allocate(this%wkf_soil(1:nlevsoil_hyd)) if(use_2d_hydrosolve) then - - this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & - + (n_hypool_aroot + nshell) * nlevsoil_hyd + + this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + + (n_hypool_aroot + nshell) * nlevsoil_hyd + + this%num_nodes = n_hypool_leaf + n_hypool_stem + n_hypool_troot & + + (n_hypool_aroot + nshell) * nlevsoil_hyd + + ! These are only in the newton-matrix solve + allocate(this%conn_up(this%num_connections)) + allocate(this%conn_dn(this%num_connections)) + allocate(this%residual(this%num_nodes)) + allocate(this%ajac(this%num_nodes,this%num_nodes)) + allocate(this%dth_node(this%num_nodes)) + allocate(this%th_node_init(this%num_nodes)) + allocate(this%psi_node_init(this%num_nodes)) + allocate(this%th_node(this%num_nodes)) + allocate(this%psi_node(this%num_nodes)) + allocate(this%blu(this%num_nodes)) + allocate(this%indices(this%num_nodes)) + allocate(this%k_bound(this%num_connections)) + allocate(this%hdiff_bound(this%num_connections)) + allocate(this%dhdpsi(this%num_connections,2)) + allocate(this%dkdpsi(this%num_connections,2)) + allocate(this%q_flux(this%num_connections)) + + else + + this%num_connections = n_hypool_leaf + n_hypool_stem + & + n_hypool_troot + n_hypool_aroot + nshell -1 + + this%num_nodes = n_hypool_leaf + n_hypool_stem + & + n_hypool_troot + n_hypool_aroot + nshell + + + - allocate(this%conn_up(this%num_connections)) - allocate(this%conn_dn(this%num_connections)) - end if + allocate(this%p_media_node(this%num_nodes)) + + + end associate From 6c45f493ed0b8f264d3728c0fb4b36c4b73937ed Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 28 Jan 2020 10:44:15 -0800 Subject: [PATCH 052/114] Partial work towards getting kmax terms setup on arbitrary hydraulics connections --- biogeophys/FatesPlantHydraulicsMod.F90 | 228 +++++++++++++++++-------- 1 file changed, 159 insertions(+), 69 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ff53601af4..f25673123f 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4430,8 +4430,37 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & sapflow,rootuptake,wb_error_site, nsteps, & dth_layershell_site, runoff_site) - use EDTypesMod , only : AREA + ! --------------------------------------------------------------------------------- + ! This solution to the plant water flux equations casts all the fluxes through a + ! cohort, and the rhizosphere shells in ALL layers as a single system of equations. + ! If thinking of the plant's above ground components as one dimension, and the soil + ! layers as another, this is a somewhat 2D system (hence "Matrix" in the name). + ! To improve the quality of the solution and reduce solver error, this also + ! uses a Newton iteration. See technical documentation for a full derivation + ! of the mathematics. However, in brief, we can describe the flux balance through + ! any node, considering flux paths labeled j, through that node in set J. + ! This is an implicit solve, so we balance the change in water mass (defined by + ! volume V, density rho, and water content theta) with the flux (q) esitmated + ! at the next time-step q^(t+1). Note that we continue to solve this equation, using + ! updated values of water content and pressure (psi), by balancing our fluxes with + ! the total of previous (theta_p) and remaining (theta_r) water contents. + ! + ! rho V rho V + ! ----- Del theta_p + ----- Del theta_r = Sum ( q^(t+1) ) + ! Del t Del t J + ! + ! The flux at t+1, is simply the current flux (q) and a first order Taylor + ! expanion (i.e. forward-euler) estimate with the current derivative based + ! on the current value of theta and psi. + ! Note also, that the solution is in terms of the matric potential, psi. This + ! conversion from theta to psi, requires this derivative (Jacobian) to also + ! contain not just the rate of change of flux wrt psi, but the change in theta + ! wrt psi (self term, no cross node terms). + ! + ! ----------------------------------------------------------------------------------- + + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure @@ -4553,7 +4582,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & nstep = get_nstep() associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn ) + conn_dn => site_hydr%conn_dn ) ! Transfer node heights, volumes and initial water contents for ! the transporting root and above ground compartments to the @@ -4600,7 +4629,48 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo enddo - + + + + do icnx=1,num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + + kmax_up_dn(icnx) + + if(k <= n_hypool_leaf) then + + kmax_up_node(k) = fates_unset_r8 + kmax_lo_node(k) = cohort_hydr%kmax_petiole_to_leaf + + elseif(k <= n_hypool_ag) then + + j = k - n_pool_leaf + kmax_up_node(k) = cohort_hydr%kmax_stem_upper(j) + kmax_lo_node(k) = cohort_hydr%kmax_stem_lower(j) + + elseif(k <= (n_hpool_ag+n_hypool_troot) ) then + + kmax_up = cohort_hydr%kmax_troot_upper + kmax_lo = cohort_hydr%kmax_troot_lower(ilayer) + + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + + + + elseif(k <= (n_hpool_plant) then + + end if + + + + + end do + + + ! Initialize variables and flags that track ! the progress of the solve @@ -4629,10 +4699,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! Set the current water content as the initial [m3/m3] th_node(:) = th_node_init(:) - do k=1,num_nodes - ! Get matric potential [Mpa] - psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) - end do +! do k=1,num_nodes +! ! Get matric potential [Mpa] +! psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) +! end do tm = tm + dtime @@ -4654,80 +4724,89 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & residual(:) = 0._r8 blu(:) = 0._r8 - ! -! do k = 1, num_nodes -! call flc_from_psi(ft, pm_type(k),psi_node(k), flc_node(k), site_hydr, bc_in) -! call dflcdpsi_from_psi(ft, pm_type(k),psi_node(k), dflcdpsi_node(k), site_hydr, bc_in) -! enddo - -! call boundary_hdiff_and_k_alt(ccohort_hydr,psi_node(:),flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) + + do k=1,num_nodes ! residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) - ! Get total potential [Mpa] - h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) - - ! Get Fraction of Total Conductivity [-] - ftc_node(k) = wkf_plant(p_media_nodes(k),ft)%p%ftc_from_psi(psi_node(k)) - - ! deriv psi wrt theta - dpsi_dtheta_node(k) = wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k)) - ! deriv ftc wrt psi - - dftc_dpsi = wkf_plant(p_media_nodes(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - - dftc_dtheta_node(k) = dftc_dpsi * dpsi_dtheta_node(k) - ! This will get the effective K, and may modify FTC depending - ! on the flow direction - - call GetEffKFTC(kmax_lo,kmax_up,h_lo,h_up,ftc_lo,ftc_up, & - dftc_dtheta_lo, dftc_dtheta_up, k_eff) + if(k <= n_hypool_plant) then + psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(p_media_nodes(k),ft)%p%ftc_from_psi(psi_node(k)) + ! deriv psi wrt theta + dtheta_dpsi_node(k) = 1._r8/wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_plant(p_media_nodes(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + + + + + else + j = node_layer(k) + psi_node(k) = wrf_soil(j)%p%psi_from_th(th_node(k)) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + ! deriv psi wrt theta + dtheta_dpsi_node(k) = 1._r8/wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + end if + + - ! matrix - ic(:) = 0 - ir(:) = 0 - values(:) = 0._r8 - nc = 1 - nr = 1 - icol = k - ic(1) = icol - ir(1) = icol ! dnr = -1.e-6_r8 ! dnr = -0.005*abs(psi_node(k)) - 1e-12 - dnr = -1.e-8_r8 +!! dnr = -1.e-8_r8 ! dnr = -max(1.e-6,0.05*abs(psi_node(k))) + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + if(pm_type(k) <= n_hypool_plant) then - call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) - ! incremented psi - psi_pt = psi_node(k) + dnr - call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) - values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr - else - j = pm_type(k)-n_hypool_plant - B = bc_in%bsw_sisl(j) - psisat = bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8 !! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa - thsat = bc_in%watsat_sisl(j) - psi_pt = psi_node(k) - if( psi_pt >= -psisat ) then - tmp = 0._r8 - else - tmp = 1._r8/B*(-psi_pt/psisat)**(-1._r8-1._r8/B)/psisat - endif - values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp - endif + ! THIS IS AN EXPLICIT DERIVATIVE - values(1) = +! call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) +! ! incremented psi +! psi_pt = psi_node(k) + dnr +! call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) +! values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr - - ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) + ajac(k,k) = denh2o*v_node(k)/ & + (wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) + + + else +! j = pm_type(k)-n_hypool_plant +! B = bc_in%bsw_sisl(j) +! psisat = bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8 !! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa +! thsat = bc_in%watsat_sisl(j) +! psi_pt = psi_node(k) +! if( psi_pt >= -psisat ) then +! tmp = 0._r8 +! else +! tmp = 1._r8/B*(-psi_pt/psisat)**(-1._r8-1._r8/B) / psisat +! endif +! values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp + + ajac(k,k) = denh2o*v_node(k)/ & + (wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) + + endif + +! ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) enddo @@ -4739,12 +4818,23 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & id_up = conn_up(icnx) ir(:) = 0 ic(:) = 0 - values(:) = 0._r8 - qflx = -1._r8 * k_bound(icnx) * hdiff_bound(icnx) - if(icnx==2) sapflow =qflx - q_flux(icnx) = qflx - residual(id_dn) = residual(id_dn) - qflx - residual(id_up) = residual(id_up) + qflx + + qflx = 1._r8 * k_bound(icnx) * hdiff_bound(icnx) + +! if(icnx==2) sapflow =qflx + + ! This will get the effective K, and may modify FTC depending + ! on the flow direction + + call GetEffKFTC(kmax_lo,kmax_up,h_lo,h_up,ftc_lo,ftc_up, & + dftc_dtheta_lo, dftc_dtheta_up, k_eff) + + + +! q_flux(icnx) = -qflx + residual(id_dn) = residual(id_dn) + qflx + residual(id_up) = residual(id_up) - qflx + dqflx_dn = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,1) + k_bound(icnx)*dhdpsi(icnx,1)) dqflx_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) ir(1) = id_dn From e03c2ff9da2791d0a49bb7055623457a40f5e1be Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 28 Jan 2020 13:01:49 -0800 Subject: [PATCH 053/114] Yet, still partway through kmax on arbitrary connections --- biogeophys/FatesPlantHydraulicsMod.F90 | 195 ++++++++++++++++++++----- 1 file changed, 161 insertions(+), 34 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index f25673123f..f128f0e3a4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4631,45 +4631,172 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo - - do icnx=1,num_connections - - id_dn = conn_dn(icnx) - id_up = conn_up(icnx) + subroutine SetMaxCondConnections(site_hydr) - - kmax_up_dn(icnx) + ! This subroutine sets the maximum conductances + ! on the downstream (towards atm) and upstream (towards + ! soil) side of each connection. - if(k <= n_hypool_leaf) then - - kmax_up_node(k) = fates_unset_r8 - kmax_lo_node(k) = cohort_hydr%kmax_petiole_to_leaf - - elseif(k <= n_hypool_ag) then - - j = k - n_pool_leaf - kmax_up_node(k) = cohort_hydr%kmax_stem_upper(j) - kmax_lo_node(k) = cohort_hydr%kmax_stem_lower(j) - - elseif(k <= (n_hpool_ag+n_hypool_troot) ) then - - kmax_up = cohort_hydr%kmax_troot_upper - kmax_lo = cohort_hydr%kmax_troot_lower(ilayer) - - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - - elseif(k <= (n_hpool_plant) then - - end if - - - - - end do + associate(kmax_dn => site_hydr%kmax_dn_scr, & + kmax_up => site_hydr%kmax_up_scr) + + + ! Initialize counters + num_nds = 0 + num_cnxs = 0 + + ! Set leaf to stem connections (only 1 leaf layer + ! this will break if we have multiple, as there would + ! need to be assumptions about which compartment + ! to connect the leaves to. + icnx = 1 + cond_dn(icnx) = cohort_hydr%kmax_petiole_to_leaf + cond_up(icnx) = cohort_hydr%kmax_stem_upper(1) + + ! Stem to stem connections + do k = 2, n_hypool_ag-1 + icnx = icnx + 1 + cond_dn(icnx) = cohort_hydr%kmax_stem_lower(k-1) + cond_up(icnx) = cohort_hydr%kmax_stem_upper(k) + enddo + + ! Path is between lowest stem and transporting root + + j = n_hypool_ag + i_up = j + i_lo = j+1 + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do j=2,n_hypool_ag-1 + + i_up = j + i_lo = j+1 + + + ! "Up" compartment is the "upper" node, but uses + ! the "lower" side of its compartment for the calculation. + ! Ultimately, it is more "upper" than its counterpart + ! This compartment is the "lower" node, but uses + ! the "higher" side of its compartment. + + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + end do + + + ! Path is between lowest stem and transporting root + + j = n_hypool_ag + i_up = j + i_lo = j+1 + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between the transporting root + ! and the absorbing root for this layer + ! NOTE: No need to scale by root fraction + ! even if in parallel mode, already parallel! + + j = n_hypool_ag+1 + i_up = j + i_lo = j+1 + kmax_up = cohort_hydr%kmax_troot_lower(ilayer) + kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + j = n_hypool_ag+2 + i_up = j + i_lo = j+1 + + ! Special case. Maximum conductance depends on the + ! potential gradient. + if(h_node(i_up) < h_node(i_lo) ) then + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) + else + kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) + end if + + kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between rhizosphere shells + + print*,"THESE SHOULD BE THE SAME: ",(n_hypool_ag+2)-(n_hypool_tot-nshell) + stop + + do j = n_hypool_ag+3,n_hypool_tot-1 + + i_up = j + i_lo = j+1 + ishell_up = i_up - (n_hypool_tot-nshell) + ishell_lo = i_lo - (n_hypool_tot-nshell) + + kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant + kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant + + call GetImTaylorKAB(kmax_lo,kmax_up, & + ftc_node(i_lo),ftc_node(i_up), & + h_node(i_lo),h_node(i_up), & + dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & + dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + end do + end associate + end subroutine SetMaxCondConnections ! Initialize variables and flags that track From 47c261bb1cbf68c096b297ce2cd49992f801e7a2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 29 Jan 2020 22:38:37 -0800 Subject: [PATCH 054/114] Added some site level memory structures for media type, refactored 2d mat solve core math. --- biogeophys/FatesPlantHydraulicsMod.F90 | 609 ++++++++++++------------- main/FatesHydraulicsMemMod.F90 | 204 +++------ 2 files changed, 343 insertions(+), 470 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index f128f0e3a4..73c4455426 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -181,7 +181,7 @@ module FatesPlantHydraulicsMod ! This is a list of the porous media types for all of the compartments ! going in 1D from top down order (leaf, stem, troot, aroot, rhiz shell) - integer, allocatable :: p_media_nodes(:) + ! integer, allocatable :: p_media_nodes(:) real(r8), parameter :: alpha_vg = 0.001_r8 @@ -919,12 +919,15 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) real(r8) :: th_troot_uncorr ! uncorrected transporting root water content[m3 m-3] real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevsoi_hyd) ! uncorrected absorbing root water content[m3 m-3] real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] + integer,pointer :: pm_node(:) integer :: nstep !number of time steps !----------------------------------------------------------------------- ccohort_hydr => ccohort%co_hydr FT = cCohort%pft + pm_node = site_hydr%pm_node + ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) @@ -933,18 +936,18 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) do k=1,n_hypool_ag th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) - ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, k) + ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, pm_node(k)) enddo th_troot_uncorr = ccohort_hydr%th_troot * ccohort_hydr%v_troot_init /ccohort_hydr%v_troot - ccohort_hydr%th_troot = constrain_water_contents(th_troot_uncorr, small_theta_num, ft, 3) + ccohort_hydr%th_troot = constrain_water_contents(th_troot_uncorr, small_theta_num, ft, pm_node(3)) ccohort_hydr%errh2o_growturn_aroot = 0._r8 do j=1,currentSite%si_hydr%nlevsoi_hyd th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, 4) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, pm_node(4)) ccohort_hydr%errh2o_growturn_aroot = ccohort_hydr%errh2o_growturn_aroot + & denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_aroot_uncorr(j))*ccohort_hydr%v_aroot_layer(j) enddo @@ -970,13 +973,13 @@ end subroutine updateSizeDepTreeHydStates ! ===================================================================================== - function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) + function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) ! !ARGUMENTS: real(r8) , intent(in) :: th_uncorr ! uncorrected water content (m3 m-3) real(r8) , intent(in) :: delta integer , intent(in) :: ft - integer , intent(in) :: k + integer , intent(in) :: pm_type ! ! !Local: real(r8) :: thr ! residual water content (m3 m-3) @@ -986,8 +989,8 @@ function constrain_water_contents(th_uncorr, delta, ft, k) result(th_corr) real(r8) :: th_corr ! corrected water content ! !------------------------------------------------------------------------ - ths = EDPftvarcon_inst%hydr_thetas_node(ft,p_media_nodes(k)) - thr = ths * EDPftvarcon_inst%hydr_resid_node(ft,p_media_nodes(k)) + ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) + thr = ths * EDPftvarcon_inst%hydr_resid_node(ft,pm_type) th_corr = max((thr+delta),min((ths-delta),th_uncorr)) return @@ -3910,10 +3913,12 @@ end subroutine GetImTaylorKAB ! ===================================================================================== - subroutine GetEffKFTC(kmax_lo,kmax_up, & - h_lo,h_up, & - ftc_lo,ftc_up, & - dftc_dtheta_lo, dftc_dtheta_up, & + subroutine GetEffKFTC(kmax_dn,kmax_up, & + h_dn,h_up, & + ftc_dn,ftc_up, & + dftc_dtheta_dn, dftc_dtheta_up, & + dk_dpsi_dn, & + dk_dpsi_up, & k_eff) ! ----------------------------------------------------------------------------- @@ -3925,12 +3930,20 @@ subroutine GetEffKFTC(kmax_lo,kmax_up, & ! direction from "up"per (closer to atm) and "lo"wer (further from atm). ! ----------------------------------------------------------------------------- - real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] - real(r8),intent(inout) :: ftc_lo, ftc_up ! frac total conductance [-] - real(r8),intent(inout) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative - ! of FTC wrt relative water content - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(in) :: kmax_dn ! max conductance (downstream) [kg s-1 Mpa-1] + real(r8),intent(in) :: kmax_up ! max conductance (upstream) [kg s-1 Mpa-1] + real(r8),intent(in) :: h_dn ! total potential (downstream) [MPa] + real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] + real(r8),intent(inout) :: ftc_dn ! frac total cond (downstream) [-] + real(r8),intent(inout) :: ftc_up ! frac total cond (upstream) [-] + real(r8),intent(inout) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) + real(r8),intent(inout) :: dftc_dpsi_up ! Derivative ftc / theta (upstream) + ! of FTC wrt relative water content + real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the + ! downstream pressure node + real(r8),intent(out) :: dk_dpsi_up ! change in effective conductance from the + ! upstream pressure node + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] ! Locals real(r8) :: h_diff ! Total potential difference [MPa] @@ -3939,7 +3952,7 @@ subroutine GetEffKFTC(kmax_lo,kmax_up, & ! by the upstream node, or by both ! with a harmonic average ! Calculate difference in total potential over the path [MPa] - h_diff = h_lo - h_up + h_diff = h_up - h_dn ! If we do enable "upstream K", then we are saying that ! the fractional loss of conductivity is dictated @@ -3950,17 +3963,23 @@ subroutine GetEffKFTC(kmax_lo,kmax_up, & if(do_upstream_k) then if (h_diff>0._r8) then - ftc_up = ftc_lo - dftc_dtheta_up = 0._r8 + ftc_dn = ftc_up + dftc_dpsi_dn = 0._r8 else - ftc_lo = ftc_up - dftc_dtheta_lo = 0._r8 + ftc_up = ftc_dn + dftc_dpsi_up = 0._r8 end if end if ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_lo*kmax_lo)) + k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + + + dk_dpsi_dn = k_eff**2._r8 * kmax_dn**-1._r8 * ftc_dn**-2._r8 * dftc_dpsi_dn + + dk_dpsi_up = k_eff**2._r8 * kmax_up**-1._r8 * ftc_up**-2._r8 * dftc_dpsi_up + return @@ -4480,8 +4499,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol integer :: j, icnx, pmx integer :: id_dn, id_up - real(r8) :: psisat,B,thsat,psi_pt,tmp - real(r8) :: values(4) + !real(r8) :: psisat,B,thsat,psi_pt,tmp + + !real(r8) :: values(4) real(r8) :: wb_step_err ! water balance error over substep [kg] real(r8) :: w_tot_beg ! total plant water prior to solve [kg] @@ -4559,30 +4579,42 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8) :: acp real(r8) :: dcomp - real(r8) :: dtime, dtx, dtcf, tm, dto, dtimex, var, varx, tmx,dtime_o + real(r8) :: dtime ! Time of each substep, potentially whole step [s] + real(r8) :: dtx, dtcf, dto, dtimex, var, varx + real(r8) :: tm ! Total time integrated after each substep [s] + real(r8) :: tmx ! Total time to be integrated this step [s] real(r8) :: dwat_veg_coh integer :: nsd ! node index in B vector with highest term - integer :: niter - integer :: ntsr + integer :: niter ! number of iterations on each substep + integer :: ntsr ! number of iterations on searches less than 10 tries integer :: kshell ! rhizosphere shell index, 1->nshell integer :: outer_nodes(10) integer :: bc_cnx(10) real(r8) :: smp, h2osoi_liqvol - real(r8) :: e0(num_nodes) + real(r8) :: psiw(num_nodes) - real(r8) :: e1(num_nodes) - real(r8) :: e2(num_nodes) real(r8) :: sapflow integer :: ipiv(num_nodes) integer :: info integer :: itshk integer :: nstep !number of time steps + + + ! This is a convergence test. This is the maximum difference + ! allowed between the flux balance and the change in storage + ! on a node. [kg/s] + real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + + ! !for debug only nstep = get_nstep() associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn ) + conn_dn => site_hydr%conn_dn, & + kmax_up => site_hydr%kmax_up, & + kmax_dn => site_hydr%kmax_dn, & + ) ! Transfer node heights, volumes and initial water contents for ! the transporting root and above ground compartments to the @@ -4629,181 +4661,12 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo enddo - - - subroutine SetMaxCondConnections(site_hydr) - - ! This subroutine sets the maximum conductances - ! on the downstream (towards atm) and upstream (towards - ! soil) side of each connection. - - - - associate(kmax_dn => site_hydr%kmax_dn_scr, & - kmax_up => site_hydr%kmax_up_scr) - - - ! Initialize counters - num_nds = 0 - num_cnxs = 0 - - ! Set leaf to stem connections (only 1 leaf layer - ! this will break if we have multiple, as there would - ! need to be assumptions about which compartment - ! to connect the leaves to. - icnx = 1 - cond_dn(icnx) = cohort_hydr%kmax_petiole_to_leaf - cond_up(icnx) = cohort_hydr%kmax_stem_upper(1) - - ! Stem to stem connections - do k = 2, n_hypool_ag-1 - icnx = icnx + 1 - cond_dn(icnx) = cohort_hydr%kmax_stem_lower(k-1) - cond_up(icnx) = cohort_hydr%kmax_stem_upper(k) - enddo - - ! Path is between lowest stem and transporting root - - j = n_hypool_ag - i_up = j - i_lo = j+1 - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper - - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- - - do j=2,n_hypool_ag-1 - - i_up = j - i_lo = j+1 - - - ! "Up" compartment is the "upper" node, but uses - ! the "lower" side of its compartment for the calculation. - ! Ultimately, it is more "upper" than its counterpart - ! This compartment is the "lower" node, but uses - ! the "higher" side of its compartment. - - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - - ! Path is between lowest stem and transporting root - - j = n_hypool_ag - i_up = j - i_lo = j+1 - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between the transporting root - ! and the absorbing root for this layer - ! NOTE: No need to scale by root fraction - ! even if in parallel mode, already parallel! - - j = n_hypool_ag+1 - i_up = j - i_lo = j+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - j = n_hypool_ag+2 - i_up = j - i_lo = j+1 - - ! Special case. Maximum conductance depends on the - ! potential gradient. - if(h_node(i_up) < h_node(i_lo) ) then - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) - else - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) - end if - - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between rhizosphere shells - - print*,"THESE SHOULD BE THE SAME: ",(n_hypool_ag+2)-(n_hypool_tot-nshell) - stop - - do j = n_hypool_ag+3,n_hypool_tot-1 - - i_up = j - i_lo = j+1 - ishell_up = i_up - (n_hypool_tot-nshell) - ishell_lo = i_lo - (n_hypool_tot-nshell) - - kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant - kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - end do - end associate - end subroutine SetMaxCondConnections ! Initialize variables and flags that track ! the progress of the solve tmx = dtime - dtime_o = dtime tm = 0 ntsr = 0 @@ -4818,26 +4681,17 @@ end subroutine SetMaxCondConnections ! likely that the elapsed time through the step ! was reset (tm) and the sub-step length (dtime) ! was decreased. - - 100 continue ! Set the current water content as the initial [m3/m3] th_node(:) = th_node_init(:) -! do k=1,num_nodes -! ! Get matric potential [Mpa] -! psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) -! end do - tm = tm + dtime niter = 0 itshk = 0 - e0(:) = 0 - e1(:) = 0 - e2(:) = 0 + ! Return here if you are just continuing the ! Newton search for a solution. No need to @@ -4858,11 +4712,9 @@ end subroutine SetMaxCondConnections ! residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) - - - if(k <= n_hypool_plant) then + psi_node(k) = wrf_plant(p_media_nodes(k),ft)%p%psi_from_th(th_node(k)) ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) @@ -4872,9 +4724,6 @@ end subroutine SetMaxCondConnections dtheta_dpsi_node(k) = 1._r8/wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k)) ! deriv ftc wrt psi dftc_dpsi_node(k) = wkf_plant(p_media_nodes(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - - - else @@ -4890,97 +4739,98 @@ end subroutine SetMaxCondConnections dftc_dpsi_node(k) = wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) end if - - - - ! dnr = -1.e-6_r8 - ! dnr = -0.005*abs(psi_node(k)) - 1e-12 -!! dnr = -1.e-8_r8 - ! dnr = -max(1.e-6,0.05*abs(psi_node(k))) ! Fill the self-term on the Jacobian's diagonal with the ! the change in storage wrt change in psi. if(pm_type(k) <= n_hypool_plant) then - ! THIS IS AN EXPLICIT DERIVATIVE - -! call th_from_psi(ft, pm_type(k), psi_node(k), thx,site_hydr,bc_in) -! ! incremented psi -! psi_pt = psi_node(k) + dnr -! call th_from_psi(ft, pm_type(k), psi_pt, thx_pt,site_hydr,bc_in) -! values(1) = denh2o*v_node(k)/dtime*(thx_pt-thx)/dnr - ajac(k,k) = denh2o*v_node(k)/ & (wrf_plant(p_media_nodes(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) - else -! j = pm_type(k)-n_hypool_plant -! B = bc_in%bsw_sisl(j) -! psisat = bc_in%sucsat_sisl(j)*denh2o*grav*1.e-9_r8 !! mm * 1e-3 m/mm * 1e3 kg/m3 * 9.8 m/s2 * 1e-6 MPa/Pa = MPa -! thsat = bc_in%watsat_sisl(j) -! psi_pt = psi_node(k) -! if( psi_pt >= -psisat ) then -! tmp = 0._r8 -! else -! tmp = 1._r8/B*(-psi_pt/psisat)**(-1._r8-1._r8/B) / psisat -! endif -! values(1) = denh2o*v_node(k)/dtime*bc_in%watsat_sisl(j)*tmp - + ajac(k,k) = denh2o*v_node(k)/ & (wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) endif - -! ajac(ir(1),ic(1)) = ajac(ir(1),ic(1)) + values(1) enddo + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + ! calculate boundary fluxes nr = 2 nc = 2 do icnx=1,num_connections + id_dn = conn_dn(icnx) id_up = conn_up(icnx) - ir(:) = 0 - ic(:) = 0 - qflx = 1._r8 * k_bound(icnx) * hdiff_bound(icnx) - -! if(icnx==2) sapflow =qflx + ! The row (first index) of the Jacobian (ajac) represents the + ! the node for which we are calculating the water balance + ! The column (second index) of the Jacobian represents the nodes + ! on which the pressure differentials effect the water balance + ! of the node of the first index. ! This will get the effective K, and may modify FTC depending ! on the flow direction - call GetEffKFTC(kmax_lo,kmax_up,h_lo,h_up,ftc_lo,ftc_up, & - dftc_dtheta_lo, dftc_dtheta_up, k_eff) - - + call GetKdKdPsi(kmax_dn(icnx), & + kmax_up(icnx), & + h_node(id_dn), & + h_node(id_up), & + ftc_node(id_dn), & + ftc_node(id_up), & + dftc_dpsi_node(id_dn), & + dftc_dpsi_node(id_up), & + dk_dpsi_dn, & + dk_dpsi_up, & + k_eff) + + qflx = k_eff*(h_node(id_up)-h_node(id_dn)) -! q_flux(icnx) = -qflx - residual(id_dn) = residual(id_dn) + qflx - residual(id_up) = residual(id_up) - qflx - dqflx_dn = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,1) + k_bound(icnx)*dhdpsi(icnx,1)) - dqflx_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) - ir(1) = id_dn - ir(2) = id_up - ic(1) = id_dn - ic(2) = id_up - values(1) = -dqflx_dn - values(2) = -dqflx_up - values(3) = dqflx_dn - values(4) = dqflx_up - - ajac(ir(1),ic(1:2)) = ajac(ir(1),ic(1:2)) + values(1:2) - ajac(ir(2),ic(1:2)) = ajac(ir(2),ic(1:2)) + values(3:4) + ! See equation (22) in technical documentation + ! Add fluxes at current time to the residual + residual(id_dn) = residual(id_dn) - qflx + residual(id_up) = residual(id_up) + qflx + + ! This is the Jacobian term related to the pressure changes on the down-stream side + ! and these are applied to both the up and downstream sides (oppositely) + dqflx_dpsi_dn = -keff + h_diff * dk_dpsi_dn + + ! This is the Jacobian term related to the pressure changes on the up-stream side + ! and these are applied to both the up and downstream sides (oppositely) + ! dqflx_dpsi_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) + + dqflx_dpsi_up = keff + h_diff * dk_dpsi_up + + ! Down-stream node's contribution to the down-stream node's Jacobian + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn + + ! Down-stream node's contribution to the up-stream node's Jacobian + ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn + + ! Up-stream node's contribution to the down-stream node's Jacobian + ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up + + ! Up-stream node's contribution to the up-stream node's Jacobian + ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up + enddo - ! - residual(1) = residual(1) + qtop - residual(:) = -residual(:) + ! Add the transpiration flux (known, retrieved from photosynthesis scheme) + ! to the mass balance on the leaf (1st) node. This is constant over + ! the time-step, so no Jacobian term needed (yet) + + residual(1) = residual(1) + qtop + icnv = 3 @@ -4988,9 +4838,10 @@ end subroutine SetMaxCondConnections ! if(nstep==15764) print *,'ft,it,residual_amax-',ft,niter,residual_amax,'qtop',qtop,psi_node, ! 'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node - ! Residual at this point, is the RHS of the matrix equation. In this next - ! step we are simply identifying if these terms are finite and how - ! large the largest one is. + ! If we have performed any Newton iterations, then the residual + ! may reflect a flux that balances (equals) the change in storage. If this is + ! true, then the residual is zero, and we are done with the sub-step. If it is + ! not nearly zero, then we must continue our search and perform another solve. residual_amax = 0._r8 nsd = 0 @@ -5014,21 +4865,21 @@ end subroutine SetMaxCondConnections ! should be very large, and we can ignore another ! solve attempt. - if( residual_amax > 1.e-8_r8 ) then + if( residual_amax > max_allowed_residual ) then icnv = 2 ! --------------------------------------------------------------------------- ! From Lapack documentation ! - ! subroutine dgesv(integer N, - ! integer NRHS, - ! real(r8), dimension( lda, * ) A, - ! integer LDA, - ! integer, dimension( * ) IPIV, - ! real(r8), dimension( ldb, * ) B, - ! integer LDB, - ! integer INFO ) + ! subroutine dgesv(integer N (in), + ! integer NRHS (in), + ! real(r8), dimension( lda, * ) A (in/out), + ! integer LDA (in), + ! integer, dimension( * ) IPIV (out), + ! real(r8), dimension( ldb, * ) B (in/out), + ! integer LDB (in), + ! integer INFO (out) ) ! ! DGESV computes the solution to a real system of linear equations ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. @@ -5070,33 +4921,48 @@ end subroutine SetMaxCondConnections call DGESV(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) - if ( info == -1 ) then - write(fates_log(),*) 'singular matrix in dgesv' !There is a row of zeros. + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info call endrun(msg=errMsg(sourcefile, __LINE__)) END IF - blu(:) = residual(:) - - ! update pressure - ! limit pressure change + if ( info > 0 ) then + write(fates_log(),*) 'the factorization of linear system in DGESV() generated' + write(fates_log(),*) 'a singularity at node: ',info + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! If info == 0, then + ! lapack was able to generate a solution. + ! For A * X = B, + ! Where the residual() was B, DGESV() returns + ! the solution X into the residual array. + + ! Update the matric potential of each node. Since this is a search + ! we update matric potential as only a fraction of delta psi (residual) + do k = 1, num_nodes - if(pm_type(k) >= 4) then - ! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx1 - !if(abs(blu(k))> abs(psi_node(k))) then - ! psi_node(k) = psi_node(k) + blu(k)*rlfx1*0.5 - !else - psi_node(k) = psi_node(k) + blu(k)*rlfx_soil - !endif + if(pm_type(k) >= 4) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_soil else - ! psi_node(k) = psi_node(k) + sign(min(abs(0.1*psi_node(k)),abs(blu(k))),blu(k))*rlfx - psi_node(k) = psi_node(k) + blu(k) * rlfx_plnt + psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt endif - + enddo + endif + + ! In this case, we still have a non-trivially small + ! residual, yet we have exceeded our iteration cap + ! Thus we set error flag to 1, which forces a time-step + ! shortening if( icnv == 2 .and. niter > 200) then icnv = 1 endif + + + ! In this case, if(niter > 500) then rlfx_plnt = 0.4_r8 rlfx_soil = 0.1_r8 @@ -5135,9 +5001,20 @@ end subroutine SetMaxCondConnections icnv = 4 endif endif + + ! Update water content do k=1,num_nodes - call th_from_psi(ft,pm_type(k),psi_node(k),th_node(k),site_hydr,bc_in) + + if( pm_node(k) == rhiz_p_media ) then + j = node_layer(k) + th_node(k) = wrf_soil(j)%p%th_from_psi(psi_node(k)) + else + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) + end if + enddo + + if(icnv == 1) then goto 100 elseif(icnv == 2) then @@ -5219,7 +5096,99 @@ end subroutine SetMaxCondConnections return end subroutine MatSolve2D - ! ===================================================================================== + ! ===================================================================================== + + subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node,aroot_frac_plant, & + kmax_dn,kmax_up) + + ! ------------------------------------------------------------------------------- + ! This subroutine sets the maximum conductances + ! on the downstream (towards atm) and upstream (towards + ! soil) side of each connection. This scheme is somewhat complicated + ! by the fact that the direction of flow at the root surface impacts + ! which root surface radial conductance to use, which makes these calculation + ! dependent on the updating potential in the system, and not just a function + ! of plant geometry and material properties. + ! ------------------------------------------------------------------------------- + + type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_cohort_hydr_type), intent(in),target :: ccohort_hydr + real(r8),intent(in) :: h_node(:) ! Total (matric+height) potential at each node (Mpa) + real(r8),intent(in) :: aroot_frac_plant ! Fraction of the total absorbing root mass + ! in the soil taken up by this cohort (/) + real(r8),intent(out) :: kmax_dn(:) ! Max conductance of downstream sides of connections (kg s-1 MPa-1) + real(r8),intent(out) :: kmax_up(:) ! Max conductance of upstream sides of connections (kg s-1 MPa-1) + + real(r8):: aroot_frac_plant ! Fraction of the cohort's fine-roots + ! out of the total in the current layer + integer :: icnx ! connection index + integer :: inode ! node index + integer :: istem ! stem index + integer :: k ! rhizosphere/root index (per level) + integer :: j ! soil layer index + + kmax_dn(:) = fates_unset_real + kmax_up(:) = fates_unset_real + + ! Set leaf to stem connections (only 1 leaf layer + ! this will break if we have multiple, as there would + ! need to be assumptions about which compartment + ! to connect the leaves to. + icnx = 1 + kmax_dn(icnx) = cohort_hydr%kmax_petiole_to_leaf + kmax_up(icnx) = cohort_hydr%kmax_stem_upper(1) + + ! Stem to stem connections + do istem = 1,n_hypool_stem-1 + icnx = icnx + 1 + kmax_dn(icnx) = cohort_hydr%kmax_stem_lower(istem) + kmax_up(icnx) = cohort_hydr%kmax_stem_upper(istem+1) + enddo + + ! Path is between lowest stem and transporting root + icnx = icnx + 1 + kmax_dn(icnx) = cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_up(icnx) = cohort_hydr%kmax_troot_upper + + ! Path is between the transporting root and the absorbing roots + inode = n_hypool_ag + do j = 1,site_hydr%nlevsoil_hyd + + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = 1, n_hypool_aroot + nshell + icnx = icnx + 1 + inode = inode + 1 + if( k == 1 ) then !troot-aroot + kmax_dn(icnx) = cohort_hydr%kmax_troot_lower(j) + kmax_up(icnx) = cohort_hydr%kmax_aroot_upper(j) + + elseif( k == 2) then ! aroot-soil + + ! Special case. Maximum conductance depends on the + ! potential gradient. + + if(h_node(inode) < h_node(inode+1) ) then + kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(j)) + else + kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(j)) + end if + kmax_up(icnx) = site_hydr%kmax_upper_shell(j,1)*aroot_frac_plant + + else ! soil - soil + kmax_dn(icnx) = site_hydr%kmax_lower_shell(j,k-1)*aroot_frac_plant + kmax_up(icnx) = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + endif + enddo + + end do + + + end subroutine SetMaxCondConnections + + ! ===================================================================================== subroutine InitHydroGlobals() @@ -5313,25 +5282,25 @@ subroutine InitHydroGlobals() end do ! Create a lookup table that gives the porous media index from the node index - allocate(p_media_nodes(n_hypool_tot)) +!! allocate(p_media_nodes(n_hypool_tot)) - do inode = 1,n_hypool_leaf - p_media_nodes(inode) = leaf_p_media - end do +!! do inode = 1,n_hypool_leaf +!! p_media_nodes(inode) = leaf_p_media +!! end do - do inode = n_hypool_leaf+1,n_hypool_leaf+n_hypool_ag - p_media_nodes(inode) = stem_p_media - end do +!! do inode = n_hypool_leaf+1,n_hypool_leaf+n_hypool_ag +!! p_media_nodes(inode) = stem_p_media +!! end do - inode = n_hypool_ag+1 - p_media_nodes(inode) = troot_p_media +!! inode = n_hypool_ag+1 +!! p_media_nodes(inode) = troot_p_media - inode = n_hypool_ag+2 - p_media_nodes(inode) = aroot_p_media +!! inode = n_hypool_ag+2 +!! p_media_nodes(inode) = aroot_p_media - do inode = n_hypool_ag+3,n_hypool_tot - p_media_nodes(inode) = rhiz_p_media - end do +!! do inode = n_hypool_ag+3,n_hypool_tot +!! p_media_nodes(inode) = rhiz_p_media +!! end do return diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index fc8cfa0702..1ea1b2bb7d 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -140,17 +140,11 @@ module FatesHydraulicsMemMod ! and type map for the whole system of compartments, from the soil to leaf ! as one vector - integer, parameter, public :: num_connections - integer, allocatable, public, protected :: conn_up(:) - integer, allocatable, public, protected :: conn_dn(:) - - - - - + integer, protected :: num_connections + integer, allocatable, protected :: conn_up(:) + integer, allocatable, protected :: conn_dn(:) + integer, allocatable, protected :: pm_type(:) -! integer, allocatable, public, protected :: pm_type(:) - contains @@ -398,19 +392,12 @@ subroutine InitHydrSite(this) allocate(this%conn_dn(this%num_connections)) allocate(this%residual(this%num_nodes)) allocate(this%ajac(this%num_nodes,this%num_nodes)) - allocate(this%dth_node(this%num_nodes)) allocate(this%th_node_init(this%num_nodes)) allocate(this%psi_node_init(this%num_nodes)) allocate(this%th_node(this%num_nodes)) allocate(this%psi_node(this%num_nodes)) - allocate(this%blu(this%num_nodes)) - allocate(this%indices(this%num_nodes)) - allocate(this%k_bound(this%num_connections)) - allocate(this%hdiff_bound(this%num_connections)) - allocate(this%dhdpsi(this%num_connections,2)) - allocate(this%dkdpsi(this%num_connections,2)) allocate(this%q_flux(this%num_connections)) - + allocate(this%pm_node(this%num_nodes)) else this%num_connections = n_hypool_leaf + n_hypool_stem + & @@ -419,22 +406,20 @@ subroutine InitHydrSite(this) this%num_nodes = n_hypool_leaf + n_hypool_stem + & n_hypool_troot + n_hypool_aroot + nshell - - - - + allocate(this%conn_up(this%num_connections)) + allocate(this%conn_dn(this%num_connections)) + allocate(this%pm_node(this%num_nodes)) + + end if - allocate(this%p_media_node(this%num_nodes)) - - - - end associate return end subroutine InitHydrSite + ! =================================================================================== + subroutine SetConnections(this) class(ed_site_hydr_type),intent(inout) :: this @@ -445,137 +430,56 @@ subroutine SetConnections(this) integer :: nt_ab num_cnxs = 0 + num_nds = 0 do k = 1, n_hypool_leaf num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom - conn_up(num_cnxs) = k + 1 + num_nds = num_nds + 1 + this%conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom + this%conn_up(num_cnxs) = k + 1 + this%pm_type(num_nds) = leaf_p_media enddo do k = n_hypool_leaf+1, n_hypool_ag num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k - conn_up(num_cnxs) = k+1 + num_nds = num_nds + 1 + this%conn_dn(num_cnxs) = k + this%conn_up(num_cnxs) = k+1 + this%pm_type(num_nds) = stem_p_media enddo + + if(use_2d_hydrosolve) then - num_nds = n_hypool_ag+n_hypool_troot - node_tr_end = num_nds - nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot - num_cnxs = n_hypool_ag + num_nds = n_hypool_ag+n_hypool_troot + node_tr_end = num_nds + nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot + num_cnxs = n_hypool_ag + + this%pm_type(num_nds) = troot_p_media + + do j = 1,this%nlevsoil_hyd + do k = 1, n_hypool_aroot + nshell + num_nds = num_nds + 1 + num_cnxs = num_cnxs + 1 + if( k == 1 ) then !troot-aroot + !junction node + this%conn_dn(num_cnxs) = node_tr_end !absorbing root + this%conn_up(num_cnxs) = num_nds + this%pm_type(num_nds) = aroot_p_media + else + this%conn_dn(num_cnxs) = num_nds - 1 + this%conn_up(num_cnxs) = num_nds + this%pm_type(num_nds) = rhiz_p_media + endif + enddo + end do + else + + this%pm_type(num_hypool_ag+1) = troot_p_media + this%pm_type(num_hypool_ag+2) = aroot_p_media + this%pm_type(num_hypool_ag+3:num_hypool_ag+2+nshell) = rhiz_p_media + + end if - do j = 1,this%nlevsoil_hyd - do k = 1, n_hypool_aroot + nshell - num_nds = num_nds + 1 - num_cnxs = num_cnxs + 1 - if( k == 1 ) then !troot-aroot - !junction node - conn_dn(num_cnxs) = node_tr_end !absorbing root - conn_up(num_cnxs) = num_nds - else - conn_dn(num_cnxs) = num_nds - 1 - conn_up(num_cnxs) = num_nds - endif - enddo - end do - - end subroutine SetConnections - - -! ===================================================================================== - subroutine SetPhsOrganConnection(this) -! - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer :: k ! local indexing - integer :: num_cnxs - integer :: num_nds - integer :: nt_ab - integer :: s, c, pi, p_t - class(ed_cohort_hydr_type),intent(inout) :: this - !---------------------------------------------------------------------- - - associate( & - conn_up => this%conn_up, & - conn_dn => this%conn_dn, & - pm_type => this%pm_type & - ) -! - pm_type(:) = 0 - num_nds = 0 - num_cnxs = 0 - do k = 1, n_hypool_leaf - pm_type(k) = k - num_nds = num_nds + 1 - num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom - conn_up(num_cnxs) = k + 1 - enddo - do k = n_hypool_leaf+1, n_hypool_ag - pm_type(k) = k - num_nds = num_nds + 1 - num_cnxs = num_cnxs + 1 - conn_dn(num_cnxs) = k - conn_up(num_cnxs) = k+1 - enddo - do k=n_hypool_ag+1, n_hypool_ag+n_hypool_troot - pm_type(k) = k - num_nds = num_nds + 1 - enddo - end associate -! - end subroutine SetPhsOrganConnection - ! ===================================================================================== - subroutine SetPhsSoilConnection(this) -! - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - integer :: j,k ! local indexing - integer :: num_cnxs - integer :: num_cnx - integer :: num_nds - integer :: nt_ab - integer :: node_tr_end - class(ed_cohort_hydr_type),intent(inout) :: this - ! lower - towards the soil (k relate to _dn), upper - towards the atmosphere - ! (k+1 to _up) - ! - !---------------------------------------------------------------------- - associate( & - conn_up => this%conn_up, & - conn_dn => this%conn_dn, & - pm_type => this%pm_type, & - nlevsoil_hyd => this%nlevsoi_hyd & - ) - num_nds = n_hypool_ag+n_hypool_troot - node_tr_end = num_nds - nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot - num_cnxs = n_hypool_ag - do j = 1,nlevsoil_hyd - do k = 1, n_hypool_aroot + nshell - num_nds = num_nds + 1 - if(k <=n_hypool_aroot) then - pm_type(num_nds) = n_hypool_ag+n_hypool_troot+k - else - pm_type(num_nds) = nt_ab+j - endif - num_cnxs = num_cnxs + 1 - if( k == 1 ) then !troot-aroot - !junction node - conn_dn(num_cnxs) = node_tr_end !absorbing root - conn_up(num_cnxs) = num_nds - else - conn_dn(num_cnxs) = num_nds - 1 - conn_up(num_cnxs) = num_nds - endif - enddo -! - enddo ! end soil layer - end associate - end subroutine SetPhsSoilConnection - - ! =================================================================================== - - - - + end subroutine SetConnections end module FatesHydraulicsMemMod From c29078163ddc066455a148c85a35dfe68dafef1f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Jan 2020 13:55:04 -0800 Subject: [PATCH 055/114] More refactors toward newton-matrix hydraulics. --- biogeophys/FatesPlantHydraulicsMod.F90 | 401 ++++++++++++------------- main/FatesHydraulicsMemMod.F90 | 25 +- 2 files changed, 212 insertions(+), 214 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 73c4455426..828663d589 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -61,7 +61,6 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : CrownDepth use FatesAllometryMod , only : set_root_fraction use FatesAllometryMod , only : i_hydro_rootprof_context - use FatesHydraulicsMemMod, only: use_2d_hydrosolve use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type @@ -179,9 +178,7 @@ module FatesPlantHydraulicsMod class(wkf_arr_type), pointer :: wkf_plant(:,:) - ! This is a list of the porous media types for all of the compartments - ! going in 1D from top down order (leaf, stem, troot, aroot, rhiz shell) - ! integer, allocatable :: p_media_nodes(:) + real(r8), parameter :: alpha_vg = 0.001_r8 @@ -919,14 +916,14 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) real(r8) :: th_troot_uncorr ! uncorrected transporting root water content[m3 m-3] real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevsoi_hyd) ! uncorrected absorbing root water content[m3 m-3] real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] - integer,pointer :: pm_node(:) + integer :: nstep !number of time steps !----------------------------------------------------------------------- ccohort_hydr => ccohort%co_hydr FT = cCohort%pft - - pm_node = site_hydr%pm_node + + associate(pm_node = site_hydr%pm_node) ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. @@ -967,7 +964,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 - + end associate end subroutine updateSizeDepTreeHydStates @@ -2442,10 +2439,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) if(use_2d_hydrosolve) then - ! call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & - ! dtime,qflx_tran_veg_indiv, & - ! sapflow,rootuptake,wb_error_site,nsteps, & - ! dth_layershell_col,site_runoff) + call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake,wb_error_site,nsteps, & + dth_layershell_col,site_runoff) else @@ -3102,6 +3099,9 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & logical, parameter :: do_scale_allkmax_rootfr = .true. + associate(pm_node => site_hydr%pm_node) + + ! This is the maximum number of iterations needed for this cohort ! (each soil layer has a different number, this saves the max) ccohort_hydr%iterh1 = 0 @@ -3258,20 +3258,20 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & do i = 1,n_hypool_plant ! Get matric potential [Mpa] - psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) ! Get total potential [Mpa] h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) ! Get Fraction of Total Conductivity [-] - ftc_node(i) = wkf_plant(p_media_nodes(i),ft)%p%ftc_from_psi(psi_node(i)) + ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) ! deriv psi wrt theta - dpsi_dtheta_node(i) = wrf_plant(p_media_nodes(i),ft)%p%dpsidth_from_th(th_node(i)) + dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) ! deriv ftc wrt psi - dftc_dpsi = wkf_plant(p_media_nodes(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) @@ -3518,7 +3518,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Calculate new psi for checks do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(p_media_nodes(i),ft)%p%psi_from_th(th_node(i)) + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) end do do i = n_hypool_plant+1,n_hypool_tot psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) @@ -3719,7 +3719,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & enddo !soil layer (jj -> ilayer) - + end associate return end subroutine ImTaylorSolve1D @@ -3746,7 +3746,7 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots - ! in the soil continuum is from current plant? + ! in the soil continuum is from current plant? integer, intent(in) :: err_code ! error code real(r8), intent(in) :: err_arr(:) ! error diagnostic @@ -3772,7 +3772,7 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & write(fates_log(),*) 'error diag: ',err_arr(:) do inode = 1,n_hypool_plant - psi_node(inode) = wrf_plant(p_media_nodes(inode),ft)%p%psi_from_th(th_node(inode)) + psi_node(inode) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(inode)) h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) end do do inode = n_hypool_plant+1,n_hypool_tot @@ -3913,10 +3913,11 @@ end subroutine GetImTaylorKAB ! ===================================================================================== - subroutine GetEffKFTC(kmax_dn,kmax_up, & + subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & h_dn,h_up, & ftc_dn,ftc_up, & - dftc_dtheta_dn, dftc_dtheta_up, & + dftc_dtheta_dn, & + dftc_dtheta_up, & dk_dpsi_dn, & dk_dpsi_up, & k_eff) @@ -3936,8 +3937,7 @@ subroutine GetEffKFTC(kmax_dn,kmax_up, & real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] real(r8),intent(inout) :: ftc_dn ! frac total cond (downstream) [-] real(r8),intent(inout) :: ftc_up ! frac total cond (upstream) [-] - real(r8),intent(inout) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8),intent(inout) :: dftc_dpsi_up ! Derivative ftc / theta (upstream) + ! of FTC wrt relative water content real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the ! downstream pressure node @@ -3946,6 +3946,8 @@ subroutine GetEffKFTC(kmax_dn,kmax_up, & real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] ! Locals + real(r8) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) + real(r8) :: dftc_dpsi_up ! Derivative ftc / theta (upstream) real(r8) :: h_diff ! Total potential difference [MPa] logical, parameter :: do_upstream_k = .true. ! the effective fraction of total ! conductivity is either governed @@ -3983,7 +3985,7 @@ subroutine GetEffKFTC(kmax_dn,kmax_up, & return - end subroutine GetEffKFTC + end subroutine GetKAndDKDPsi subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) @@ -4496,71 +4498,24 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8),intent(inout) :: runoff_site - integer :: k,ft, nt_ab,nr,nc,ic(2),ir(2),icol - integer :: j, icnx, pmx + integer :: k, ft + integer :: j, icnx integer :: id_dn, id_up - !real(r8) :: psisat,B,thsat,psi_pt,tmp - - !real(r8) :: values(4) real(r8) :: wb_step_err ! water balance error over substep [kg] real(r8) :: w_tot_beg ! total plant water prior to solve [kg] real(r8) :: w_tot_end ! total plant water at end of solve [kg] real(r8) :: dt_substep ! timestep length of substeps [s] - - ! Move these to site-level scratch space - ! -! real(r8) :: residual(num_nodes) -! real(r8) :: ajac(num_nodes,num_nodes) -! real(r8) :: dth_node(num_nodes) -! real(r8) :: th_node_init(num_nodes) -! real(r8) :: psi_node_init(num_nodes) -! real(r8) :: th_node(num_nodes) -! real(r8) :: psi_node(num_nodes) -! real(r8) :: blu(num_nodes) -! integer :: indices(num_nodes) -! real(r8) :: k_bound(num_connections) -! real(r8) :: hdiff_bound(num_connections) -! real(r8) :: dhdpsi(num_connections,2) -! real(r8) :: dkdpsi(num_connections,2) -! real(r8) :: q_flux(num_connections) - - real(r8) :: hdiffx, k_boundx, dkdpsix + real(r8) :: qflx ! water flux at current step [kg/s] + ! (from upstream to downstream node +pos) - real(r8) :: dt_time - real(r8) :: dnr, thx, thx_pt - real(r8) :: qflx + integer :: icnv ! Convergence flag for each solve, see flag definitions + ! below. + - real(r8) :: qtop, dqflx_dn, dqflx_up !qtop - flux from canopy, kgh2o indiv-1 s-1 - real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] - real(r8) :: dflcgsdth ! derivative of stomatal vuln curve wrt to leaf water content [m-3 m3] - real(r8) :: dqtopdflcgs ! derivative of cohort-level transpiration wrt btran [kgh2o indiv-1 s-1] - real(r8) :: dqtopdth_leaf ! derivative of transpiration rate wrt to leaf water content [kgh2o indiv-1 s-1 m-3 m-3] + real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" - real(r8) :: qscale - integer :: s - integer :: num_nds - - - ! Probably will remove these - real(r8) :: th_node_1l( n_hypool_tot) ! volumetric water in water storage compartments (single-layer soln) [m3 m-3] - real(r8) :: dpsidth_node( n_hypool_tot) ! derivative of water potential wrt to theta [MPa] - real(r8) :: flc_node( num_nodes) ! fractional loss of conductivity at water storage nodes [-] - real(r8) :: dflcdpsi_node(num_nodes) ! derivative of fractional loss of conductivity wrt psi [MPa-1] - real(r8) :: psi_node_1l( n_hypool_tot) ! water potential in water storage compartments (single-layer soln) [MPa] - real(r8) :: flc_node_1l( n_hypool_tot) ! fractional loss of conductivity (single-layer soln) [-] - real(r8) :: dflcdpsi_node_1l(n_hypool_tot) ! derivative of flc_node_1l wrt psi [MPa-1] - real(r8) :: hdiff_bound_1l( nshell+1) ! - - - - integer :: icnv ! Convergence flag for each solve - ! icnv = 1 convergence failure, B vector may have NANs - ! icnv = 2 solution is not yet in-balance, keep trying - ! icnv = 3 acceptable solution - ! icnv = 4 too many failures, not converging - real(r8) :: thsatx real(r8) :: slx @@ -4576,45 +4531,80 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - - real(r8) :: acp - real(r8) :: dcomp - real(r8) :: dtime ! Time of each substep, potentially whole step [s] - real(r8) :: dtx, dtcf, dto, dtimex, var, varx real(r8) :: tm ! Total time integrated after each substep [s] real(r8) :: tmx ! Total time to be integrated this step [s] + real(r8) :: dwat_veg_coh + integer :: nsd ! node index in B vector with highest term - integer :: niter ! number of iterations on each substep - integer :: ntsr ! number of iterations on searches less than 10 tries + integer :: nwtn_iter ! number of (Newton) iterations on each substep + integer :: ntsr ! Number of rounds of attempts we have made + ! to get a succesfull Newton solve. integer :: kshell ! rhizosphere shell index, 1->nshell - integer :: outer_nodes(10) - integer :: bc_cnx(10) - real(r8) :: smp, h2osoi_liqvol - real(r8) :: psiw(num_nodes) real(r8) :: sapflow - integer :: ipiv(num_nodes) + integer :: info - integer :: itshk integer :: nstep !number of time steps ! This is a convergence test. This is the maximum difference ! allowed between the flux balance and the change in storage - ! on a node. [kg/s] + ! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + ! Maximum number of times we re-try a round of Newton + ! iterations, each time decreasing the time-step and + ! potentially reducing relaxation factors + integer, parameter :: max_newton_rounds = 10 + + ! Maximum number of Newton iterations in each round + integer, parameter :: max_newton_iter = 200 + + ! Flag definitions for convergence flag (icnv) + ! icnv = 1 fail the round due to either wacky math, or + ! too many Newton iterations + ! icnv = 2 continue onto next iteration, + ! icnv = 3 acceptable solution + ! icnv = 4 too many failures, aborting + + integer, parameter :: icnv_fail_round = 1 + integer, parameter :: incv_cont_search = 2 + integer, parameter :: icnv_pass_round = 3 + integer, parameter :: icnv_complete_fail = 4 + + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.2_r8 + + - ! - !for debug only - nstep = get_nstep() associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn, & - kmax_up => site_hydr%kmax_up, & - kmax_dn => site_hydr%kmax_dn, & - ) + conn_dn => site_hydr%conn_dn, & + kmax_up => site_hydr%kmax_up, & + kmax_dn => site_hydr%kmax_dn, & + residual => site_hydr%residual, & + ajac => site_hydr%ajac, & + ipiv => site_hydr%ipiv, & + th_node => site_hydr%th_node, & + th_node_init => site_hydr%th_node_init, & + psi_node => site_hydr%psi_node, & + pm_node => site_hydr%pm_node, & + ftc_node => site_hydr%ftc_node, & + z_node => site_hydr%z_node, & + v_node => site_hydr%v_node, & + ft => cohort%pft) + + + !for debug only + nstep = get_nstep() + + + ! This NaN's the scratch arrays + call site_hydr%FlushSiteScratch() + ! Transfer node heights, volumes and initial water contents for ! the transporting root and above ground compartments to the @@ -4645,14 +4635,14 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! node to the edge, we ignore that last half compartment aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot + do k = 1, n_hypool_aroot + nshell inode = inode + 1 - if (k residual_amax ) then @@ -4858,16 +4841,32 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & endif enddo - if(icnv == 1) goto 199 - + if(icnv == icnv_fail_round) goto 199 ! If the solution is balanced, none of the residuals ! should be very large, and we can ignore another ! solve attempt. + if( residual_amax < max_allowed_residual ) then + + goto 201 + + ! In this case, we still have a non-trivially small + ! residual, yet we have exceeded our iteration cap + ! Thus we set error flag to 1, which forces a time-step + ! shortening + elseif( nwtn_iter > max_newton_iter) then + + icnv = icnv_fail_round + goto 199 - if( residual_amax > max_allowed_residual ) then - icnv = 2 + ! We still have some residual (perhaps this is first step), + ! have not used too many steps, so we go ahead + ! and perform a Newton iteration + else + + ! Assume a failed solution unless we find otherwise + icnv = incv_cont_search ! --------------------------------------------------------------------------- ! From Lapack documentation @@ -4953,40 +4952,29 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & endif - ! In this case, we still have a non-trivially small - ! residual, yet we have exceeded our iteration cap - ! Thus we set error flag to 1, which forces a time-step - ! shortening - if( icnv == 2 .and. niter > 200) then - icnv = 1 - endif - - - ! In this case, - if(niter > 500) then - rlfx_plnt = 0.4_r8 - rlfx_soil = 0.1_r8 - end if - 199 continue - if( icnv == 1 ) then - write(*,'(10x,a)') '--- Convergence Failure ---' - write(*,'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & + if( icnv == icnv_fail_round ) then + + write(fates_log(),'(10x,a)') '--- Convergence Failure ---' + write(fates_log(),'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & residual_amax,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) - if( ntsr < 10 ) then + + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round + if( ntsr < max_newton_rounds ) then + tm = tm - dtime ntsr = ntsr + 1 - dtx = dtime - dtcf = 0.2_r8 - dtimex = dtime * dtcf - dtime = min(dtimex,tmx-tm) - dto = dtime - var = dtime - varx = dtx + + dtime_last = dtime + dtime = min(dtime_last * dtime_rf,tmx-tm) + + write(*,'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & - 'Time Step Reduced From ',varx,'s',' to ', & - var,'s' + 'Time Step Reduced From ',dtime_last,'s',' to ', & + dtime,'s' do k = 1,num_nodes psi_node(k) = psi_node_init(k) th_node(k) = th_node_init(k) @@ -4997,8 +4985,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & !--- Number of time step reductions failure: stop simulation --- ! else - write(*,'(10x,a)') '--- Time Step Reduction Limit Exceeded---' - icnv = 4 + ! Complete failure to converge even with re-trying + ! iterations with smaller timestepps and relaxations + icnv = icnv_complete_fail endif endif @@ -5015,24 +5004,33 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo - if(icnv == 1) then + if(icnv == icnv_fail_round) then goto 100 - elseif(icnv == 2) then + elseif(icnv == incv_cont_search) then goto 200 - elseif(icnv == 3) then + elseif(icnv == icnv_pass_round) then dth_node(:) = th_node(:) - th_node_init(:) goto 201 + elseif(icnv == icnv_complete_fail) then + write(fates_log(),*) 'Newton hydraulics solve' + write(fates_log(),*) 'could not converge on a solution.' + write(fates_log(),*) 'Perhaps try increasing iteration cap,' + write(fates_log(),*) 'and decreasing relaxation factors.' + call endrun(msg=errMsg(sourcefile, __LINE__)) else - stop + write(fates_log(),*) 'unhandled failure mode in' + write(fates_log(),*) 'newton hydraulics solve' + write(fates_log(),*) 'icnv = ',icnv + call endrun(msg=errMsg(sourcefile, __LINE__)) endif - ! enddo -201 continue ! If we have reached this point, we have iterated to ! a stable solution (where residual mass balance = 0) ! It is possible that we have used a sub-step though, ! and need to continue the iteration. + +201 continue ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) @@ -5074,7 +5072,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & site_hydr%h2oveg = site_hydr%h2oveg +dwat_veg_coh*ccohort%n/AREA!*patch_wgt th_node_init(:) = th_node(:) psi_node_init(:) = psi_node(:) - enddo + enddo ! Assign the changes to the site level soil water @@ -5281,27 +5279,6 @@ subroutine InitHydroGlobals() EDPftvarcon_inst%hydr_avuln_gs(ft)]) end do - ! Create a lookup table that gives the porous media index from the node index -!! allocate(p_media_nodes(n_hypool_tot)) - -!! do inode = 1,n_hypool_leaf -!! p_media_nodes(inode) = leaf_p_media -!! end do - -!! do inode = n_hypool_leaf+1,n_hypool_leaf+n_hypool_ag -!! p_media_nodes(inode) = stem_p_media -!! end do - -!! inode = n_hypool_ag+1 -!! p_media_nodes(inode) = troot_p_media - -!! inode = n_hypool_ag+2 -!! p_media_nodes(inode) = aroot_p_media - -!! do inode = n_hypool_ag+3,n_hypool_tot -!! p_media_nodes(inode) = rhiz_p_media -!! end do - return end subroutine InitHydroGlobals diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 1ea1b2bb7d..6e7627ea47 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -1,6 +1,7 @@ module FatesHydraulicsMemMod use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_unset_r8 use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use FatesConstantsMod, only : itrue,ifalse use FatesHydroWTFMod, only : wrf_arr_type @@ -150,7 +151,7 @@ module FatesHydraulicsMemMod procedure :: InitHydrSite procedure :: SetConnections - + procedure :: FlushSiteScratch end type ed_site_hydr_type @@ -393,11 +394,13 @@ subroutine InitHydrSite(this) allocate(this%residual(this%num_nodes)) allocate(this%ajac(this%num_nodes,this%num_nodes)) allocate(this%th_node_init(this%num_nodes)) - allocate(this%psi_node_init(this%num_nodes)) allocate(this%th_node(this%num_nodes)) + allocate(this%v_node(this%num_nodes)) + allocate(this%z_node(this%num_nodes)) allocate(this%psi_node(this%num_nodes)) allocate(this%q_flux(this%num_connections)) allocate(this%pm_node(this%num_nodes)) + else this%num_connections = n_hypool_leaf + n_hypool_stem + & @@ -420,6 +423,24 @@ end subroutine InitHydrSite ! =================================================================================== + subroutine FlushSiteScratch(this) + class(ed_site_hydr_type),intent(inout) :: this + + if(use_2d_hydrosolve) then + residual(:) = fates_unset_r8 + ajac(:,:) = fates_unset_r8 + th_node_init(:) = fates_unset_r8 + th_node(:) = fates_unset_r8 + v_node(:) = fates_unset_r8 + z_node(:) = fates_unset_r8 + psi_node(:) = fates_unset_r8 + end if + + + end subroutine FlushSiteScratch + + ! =================================================================================== + subroutine SetConnections(this) class(ed_site_hydr_type),intent(inout) :: this From e791f4dc6cb2c2e6a0f33f2d85969808a4411fa9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 4 Feb 2020 15:09:30 -0800 Subject: [PATCH 056/114] Hydraulics: organized how serial and 2d solves account for mass and error, and where these terms get rectified at site level. Various debugging. --- biogeophys/FatesPlantHydraulicsMod.F90 | 766 ++++++++++++------------- main/FatesHistoryInterfaceMod.F90 | 40 +- main/FatesHydraulicsMemMod.F90 | 153 +++-- 3 files changed, 484 insertions(+), 475 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 828663d589..0db9d0ed35 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -41,6 +41,7 @@ module FatesPlantHydraulicsMod use FatesConstantsMod, only : m3_per_mm3 use FatesConstantsMod, only : cm3_per_m3 use FatesConstantsMod, only : kg_per_g + use FatesConstantsMod, only : fates_unset_r8 use EDParamsMod , only : hydr_kmax_rsurf1 use EDParamsMod , only : hydr_kmax_rsurf2 @@ -923,7 +924,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft - associate(pm_node = site_hydr%pm_node) + associate(pm_node => currentSite%si_hydr%pm_node) ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. @@ -1063,8 +1064,8 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%sapflow = ocohort_hydr%sapflow - ncohort_hydr%rootuptake = ocohort_hydr%rootuptake +! ncohort_hydr%sapflow = ocohort_hydr%sapflow +! ncohort_hydr%rootuptake = ocohort_hydr%rootuptake ncohort_hydr%qtop = ocohort_hydr%qtop ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited @@ -1131,10 +1132,10 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & - nextCohort%n*ncohort_hydr%sapflow)/newn - ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & - nextCohort%n*ncohort_hydr%rootuptake)/newn +! ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & +! nextCohort%n*ncohort_hydr%sapflow)/newn +! ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & +! nextCohort%n*ncohort_hydr%rootuptake)/newn ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & nextCohort%n*ncohort_hydr%qtop)/newn @@ -2182,6 +2183,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: iv ! leaf layer integer :: ifp ! index of FATES patch integer :: s ! index of FATES site + integer :: i ! shell index integer :: j,jj! soil layer integer :: k ! 1D plant-soil continuum array integer :: ft ! plant functional type index @@ -2218,14 +2220,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: kmax_up ! Kmax of upper rhizosphere compartments [kg s-1 Mpa-1] real(r8) :: kmax_lo ! Kamx of lower rhizosphere compartments [kg s-1 Mpa-1] - real(r8) :: wb_error ! Solve error for a single plant-layer [kg] - real(r8) :: wb_error_site ! Error reflecting difference between site storage before and after - ! integration, with the change in the uptake boundary condition - ! that we send to the HLM. [kg/m2] + real(r8) :: wb_err_plant ! Solve error for a single plant [kg] real(r8) :: wb_check_site ! the water balance error we get from summing fluxes - ! and changes in storage (this should match wb_error_site, + ! and changes in storage ! and is just a double check on our error accounting). [kg/m2] - + + real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] ! real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation ! ! or sub-residual water contents from occuring in the soil [kg/m2] @@ -2257,8 +2257,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: tmp real(r8) :: tmp1 real(r8) :: watres_local - real(r8) :: dt_step - integer :: pick_1l(nshell+1) = (/(k,k=n_hypool_ag+n_hypool_troot+1,n_hypool_tot,1)/) real(r8) :: roota, rootb ! parameters for root distribution [m-1] real(r8) :: rootfr ! root fraction at different soil layers real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) @@ -2266,7 +2264,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) logical :: recruitflag ! flag to check if there is newly recruited cohorts integer :: iter ! number of solver iterations used for each cohort x layer integer :: nsteps ! number of substeps used for the final iteration on linear solve - real(r8) :: root_flux real(r8) :: transp_flux real(r8) :: delta_plant_storage @@ -2313,8 +2310,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) prev_h2oveg = site_hydr%h2oveg prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - - wb_error_site = 0._r8 ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- @@ -2381,8 +2376,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - ccohort_hydr%sapflow = 0._r8 - ccohort_hydr%rootuptake = 0._r8 +! ccohort_hydr%sapflow = 0._r8 +! ccohort_hydr%rootuptake = 0._r8 ! Relative transpiration of this cohort from the whole patch @@ -2427,11 +2422,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! |_____| | | k-1 | k | k+1 | !--------------------------------------------------------------------------- - ccohort_hydr%errh2o = 0._r8 - ccohort_hydr%iterh1 = 0._r8 - ccohort_hydr%iterh2 = 0._r8 - ccohort_hydr%iterlayer = 0._r8 - ! This routine will update the theta values for 1 cohort's flow-path ! from leaf to the current soil layer. This does NOT @@ -2439,10 +2429,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) if(use_2d_hydrosolve) then - call MatSolve2D(site_hydr,bc_in(s),cohort,cohort_hydr, & + call MatSolve2D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake,wb_error_site,nsteps, & - dth_layershell_col,site_runoff) + sapflow,rootuptake,wb_err_plant,dwat_plant,nsteps, & + dth_layershell_col) else @@ -2462,15 +2452,35 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! layers have transporting-to-absorbing root water potential gradients of opposite sign ! ----------------------------------------------------------------------------------- - call OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered,kbg_layer) + call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) call ImTaylorSolve1D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & - sapflow,rootuptake,wb_error_site,nsteps, & - dth_layershell_col,site_runoff) + sapflow,rootuptake, & + wb_err_plant,dwat_plant, nsteps, & + dth_layershell_col) end if + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant + + ! Update total error in [kg/m2 ground] + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV + + ! Accumulate site level diagnostic of plant water change [kg/m2] + ! (this is zerod) + site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV + + ! Update total site-level stored plant water [kg/m2] + ! (this is not zerod, but incremented) + site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + + + + + + ! --------------------------------------------------------- ! Update water potential and frac total conductivity ! of plant compartments @@ -2522,8 +2532,31 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & dtime*bc_out(s)%qflx_soil2root_sisl(j) - enddo - + + ! We accept that it is possible for gravity to push + ! water into saturated soils, particularly at night when + ! transpiration has stopped. In the real world, the water + ! would be driven out of the layer, although we have no + ! boundary flux on the rhizospheres in these substeps. To accomodate + ! this, if soils are pushed beyond saturation minus a small buffer + ! then we remove that excess, send it to a runoff pool, and + ! fix the node's water content to the saturation minus buffer value + + do i = 1,nshell + if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j)-thsat_buff)) then + + ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] + site_runoff = site_runoff + & + (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o + + site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j)-thsat_buff + end if + end do + + + enddo + ! Note that the cohort-level solvers are expected to update ! site_hydr%h2oveg @@ -2570,9 +2603,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux - if( abs(wb_check_site - wb_error_site) > 1.e-10_r8 ) then + if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-10_r8 ) then write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]' - write(fates_log(),*) 'wb_error_site: ',wb_error_site + write(fates_log(),*) 'wb_error_site: ',site_hydr%errh2o_hyd write(fates_log(),*) 'wb_check_site: ',wb_check_site write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage @@ -2583,7 +2616,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Now check on total error if( abs(wb_check_site) > 1.e-6_r8 ) then write(fates_log(),*) 'FATES hydro water balance does not add up [kg/m2]' - write(fates_log(),*) 'wb_check_site: ',wb_check_site + write(fates_log(),*) 'site_hydr%errh2o_hyd: ',wb_check_site write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage write(fates_log(),*) 'site_runoff: ',site_runoff @@ -2591,7 +2624,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) end if - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + wb_error_site + site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd bc_out(s)%plant_stored_h2o_si = site_hydr%h2oveg + site_hydr%h2oveg_dead - & site_hydr%h2oveg_growturn_err - & @@ -2599,7 +2632,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%h2oveg_hydro_err ! [kg/m2] -> [mm/s] - bc_out(s)%qflx_runoff_si = site_runoff/dtime + bc_out(s)%qflx_ro_si = site_runoff/dtime !write(fates_log(),*) 'hydro wb terms: --------------------------' !write(fates_log(),*) site_hydr%h2oveg @@ -2880,10 +2913,11 @@ end subroutine UpdatePlantKmax ! =================================================================================== - subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) + subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) ! Arguments (IN) type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_cohort_type), intent(in),target :: cohort type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr @@ -2893,12 +2927,13 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) ! Locals - real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] +! real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating ! which kmax to use when forecasting uptake layer ordering [MPa] real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] + real(r8) :: ftc_aroot ! fraction of total conductivity of abs root real(r8) :: r_bg ! total estimated resistance in below ground compartments ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant @@ -2907,12 +2942,15 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) real(r8) :: psi_shell ! matric potential of a given shell [-] real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] integer :: tmp ! temporarily holds a soil layer index + integer :: ft ! functional type index of plant integer :: j,jj,k ! layer and shell indices - + kbg_tot = 0._r8 kbg_layer(:) = 0._r8 + ft = cohort%pft + do j=1,site_hydr%nlevsoi_hyd ! Path is between the absorbing root @@ -2926,17 +2964,17 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) ! Note, since their is no elevation difference between ! the absorbing root and its layer, no need to calc ! diff in total, just matric is fine [MPa] - if(ccohort_hydr%psi_aroot(j) < psi_inner_shell) then - kmax_aroot = ccohort_hydr%kmax_aroot_radial_in(j) + if(cohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) else - kmax_aroot = ccohort_hydr%kmax_aroot_radial_out(j) + kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) end if ! Get matric potential [Mpa] of the absorbing root - psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(cohort_hydr%th_aroot(j)) ! Get Fraction of Total Conductivity [-] of the absorbing root - ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) + ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) ! Calculate total effective conductance over path [kg s-1 MPa-1] ! from absorbing root node to 1st rhizosphere shell @@ -2945,7 +2983,7 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort_hydr,ordered, kbg_layer) ! Path is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment - aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) do k = 1,nshell @@ -2988,7 +3026,8 @@ end subroutine OrderLayersForSolve1D ! ================================================================================= subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & - ordered,kbg_layer,sapflow,rootuptake,wb_err_site,nsteps,dth_layershell_col, runoff) + ordered,kbg_layer, sapflow,rootuptake,& + wb_err_plant,dwat_plant,nsteps,dth_layershell_col) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -3007,7 +3046,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Arguments (IN) type(ed_cohort_type),intent(in),target :: cohort - type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + type(ed_cohort_hydr_type),intent(inout),target :: cohort_hydr type(ed_site_hydr_type), intent(in),target :: site_hydr type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions real(r8), intent(in) :: dtime @@ -3019,16 +3058,18 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - real(r8),intent(inout) :: wb_err_site ! total error over site, transpiration - ! should match change in storage [kg/m2] - integer,intent(out) :: iter ! iteration count for sub-step loops + real(r8),intent(out) :: wb_err_plant ! total error from the plant, transpiration + ! should match change in storage [kg] + + real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] + integer,intent(out) :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows real(r8),intent(inout) :: dth_layershell_col(:,:) ! accumulated water content change over all cohorts in a column [m3 m-3]) - real(r8),intent(inout) :: runoff ! mass of water generated by preventing super-saturation of soils [kg/m2] ! Locals integer :: i ! node index "i" integer :: j ! path index "j" + integer :: jj integer :: ilayer ! soil layer index of interest integer :: itest ! node index used for testing and reporting errors integer :: ishell ! rhizosphere shell index of the node @@ -3053,7 +3094,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & real(r8) :: root_water ! kg of water in the transp and absorbing roots real(r8) :: wb_err_layer ! balance error for the layer [kg/cohort] - real(r8) :: dwat_veg_coh ! total indiv change in stored vegetation water over a timestep [kg] + real(r8) :: dth_node(n_hypool_tot) ! change in theta over the timestep real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] @@ -3086,7 +3127,8 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: roota, rootb ! rooting depth parameters (used for diagnostics) real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) - ! out of the total absorbing roots from the whole community of plants + ! out of the total absorbing roots from the whole community of plants + integer :: iter ! iteration count for sub-step loops integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps ! by this much @@ -3097,17 +3139,29 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & logical, parameter :: no_ftc_radialk = .false. logical, parameter :: do_scale_allkmax_rootfr = .true. - + logical, parameter :: weight_serial_dt = .true. associate(pm_node => site_hydr%pm_node) - ! This is the maximum number of iterations needed for this cohort ! (each soil layer has a different number, this saves the max) - ccohort_hydr%iterh1 = 0 + cohort_hydr%iterh1 = 0 - + ! Initialize plant water error (integrated flux-storage) + wb_err_plant = 0._r8 + ! Initialize integrated change in total plant water + dwat_plant = 0._r8 + + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps + + sapflow = 0._r8 + rootuptake = 0._r8 + + ! ----------------------------------------------------------------------------------- ! As mentioned when calling this routine, we calculate a solution to the flux ! equations, sequentially, for the plant and each soil layer. @@ -3214,13 +3268,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & do while( .not.solution_found ) - ! These are diagnostics that must be calculated. - ! in this routine (uses differentials and actual fluxes) - ! So we need to zero them, as they are incremented - ! over the sub-steps - sapflow = 0._r8 - rootuptake = 0._r8 ! Gracefully quit if too many iterations have been used if(iter>max_iter)then @@ -3533,27 +3581,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & exit end if - ! We accept that it is possible for gravity to push - ! water into saturated soils, particularly at night when - ! transpiration has stopped. In the real world, the water - ! would be driven out of the layer, although we have no - ! boundary flux on the rhizospheres in these substeps. To accomodate - ! this, if soils are pushed beyond saturation minus a small buffer - ! then we remove that excess, send it to a runoff pool, and - ! fix the node's water content to the saturation minus buffer value - - do i = 1,nshell - ishell = n_hypool_tot-nshell+i - if(th_node(ishell)>(bc_in%watsat_sisl(ilayer)-thsat_buff)) then - - ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] - runoff = runoff + & - (th_node(ishell)-(bc_in%watsat_sisl(ilayer)-thsat_buff)) * & - v_node(ishell)*AREA_INV - - th_node(ishell) = (bc_in%watsat_sisl(ilayer)-thsat_buff - end if - end do !if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then ! solution_found = .false. @@ -3652,52 +3679,33 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Record the layer with the most iterations, but only ! if it greater than 1. It will default to zero ! if no layers took extra iterations. - if( (real(iter)>ccohort_hydr%iterh1) .and. (iter>1) )then - ccohort_hydr%iterlayer = real(ilayer) + if( (real(iter)>cohort_hydr%iterh1) .and. (iter>1) )then + cohort_hydr%iterlayer = real(ilayer) end if ! Save the number of times we refined our sub-step counts (iterh1) - ccohort_hydr%iterh1 = max(ccohort_hydr%iterh1,real(iter)) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter)) ! Save the number of sub-steps we ultimately used - ccohort_hydr%iterh2 = max(ccohort_hydr%iterh2,real(nsteps)) + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps)) ! Update water contents in the relevant plant compartments [m3/m3] ! ------------------------------------------------------------------------------- ! Leaf and above-ground stems - ccohort_hydr%th_ag(1:n_hypool_ag) = ccohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) ! Transporting root - ccohort_hydr%th_troot = ccohort_hydr%th_troot + dth_node(n_hypool_ag+1) + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) ! Absorbing root - ccohort_hydr%th_aroot(ilayer) = ccohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) + cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) ! Change in water per plant [kg/plant] - dwat_veg_coh = & - (sum(dth_node(1:n_hypool_ag)*ccohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*ccohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*ccohort_hydr%v_aroot_layer(ilayer))*denh2o - - ! Accumulate site level diagnostic of plant water change [kg/m2] - ! (this is zerod) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_veg_coh*ccohort%n*AREA_INV + dwat_plant = dwat_plant + & + (sum(dth_node(1:n_hypool_ag)*cohort_hydr%v_ag(1:n_hypool_ag)) + & + dth_node(n_hypool_ag+1)*cohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*cohort_hydr%v_aroot_layer(ilayer))*denh2o - ! Update total site-level stored plant water [kg/m2] - ! (this is not zerod, but incremented) - site_hydr%h2oveg = site_hydr%h2oveg + dwat_veg_coh*ccohort%n*AREA_INV - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_layer - - ! Update total error in [kg/m2 ground] - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_layer*ccohort%n*AREA_INV - - ! This is same as above, but just for the current time-step - ! used for mass balance checking [kg/m2] - wb_err_site = wb_err_site + wb_err_layer*ccohort%n*AREA_INV - - - ccohort_hydr%sapflow = ccohort_hydr%sapflow + sapflow - ccohort_hydr%rootuptake(ilayer) = ccohort_hydr%rootuptake(ilayer) + rootuptake + wb_err_plant = wb_err_plant + wb_err_layer ! Save the change in water mass in the rhizosphere. Note that we did ! not immediately update the state variables upon completing each @@ -3708,14 +3716,14 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & if(site_hydr%l_aroot_layer(ilayer) ilayer) @@ -3751,7 +3759,7 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & real(r8), intent(in) :: err_arr(:) ! error diagnostic type(ed_cohort_hydr_type),pointer :: cohort_hydr - integer :: inode + integer :: i integer :: ft real(r8) :: leaf_water real(r8) :: stem_water @@ -3771,13 +3779,13 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & write(fates_log(),*) 'error code: ',err_code write(fates_log(),*) 'error diag: ',err_arr(:) - do inode = 1,n_hypool_plant - psi_node(inode) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(inode)) - h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(site_hydr%pm_node(i),ft)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) end do - do inode = n_hypool_plant+1,n_hypool_tot - psi_node(inode) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(inode)) - h_node(inode) = mpa_per_pa*denh2o*grav_earth*z_node(inode) + psi_node(inode) + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) end do @@ -3916,8 +3924,8 @@ end subroutine GetImTaylorKAB subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & h_dn,h_up, & ftc_dn,ftc_up, & - dftc_dtheta_dn, & - dftc_dtheta_up, & + dftc_dpsi_dn, & + dftc_dpsi_up, & dk_dpsi_dn, & dk_dpsi_up, & k_eff) @@ -3937,6 +3945,8 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] real(r8),intent(inout) :: ftc_dn ! frac total cond (downstream) [-] real(r8),intent(inout) :: ftc_up ! frac total cond (upstream) [-] + real(r8),intent(inout) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) + real(r8),intent(inout) :: dftc_dpsi_up ! derivative ftc / theta (upstream) ! of FTC wrt relative water content real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the @@ -3946,8 +3956,6 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] ! Locals - real(r8) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8) :: dftc_dpsi_up ! Derivative ftc / theta (upstream) real(r8) :: h_diff ! Total potential difference [MPa] logical, parameter :: do_upstream_k = .true. ! the effective fraction of total ! conductivity is either governed @@ -3978,9 +3986,9 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) - dk_dpsi_dn = k_eff**2._r8 * kmax_dn**-1._r8 * ftc_dn**-2._r8 * dftc_dpsi_dn + dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dn**(-2._r8) * dftc_dpsi_dn - dk_dpsi_up = k_eff**2._r8 * kmax_up**-1._r8 * ftc_up**-2._r8 * dftc_dpsi_up + dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_up**(-2._r8) * dftc_dpsi_up @@ -4370,86 +4378,12 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) end subroutine Hydraulics_Tridiagonal - ! ===================================================================================== - - subroutine boundary_hdiff_and_k_alt(ccohort_hydr,psi_node,flc_node,dflcdpsi_node,hdiff_bound,k_bound,dhdpsi,dkdpsi) - ! - ! !ARGUMENTS - type(ed_cohort_hydr_type) :: ccohort_hydr - real(r8) :: psi_node(num_nodes) - real(r8) :: flc_node(num_nodes) - real(r8) :: dflcdpsi_node(num_nodes) - real(r8) , intent(out) :: hdiff_bound(num_connections) !total water potential difference across lower boundary [MPa] - real(r8) , intent(out) :: dhdpsi(num_connections,2) ! - real(r8) , intent(out) :: k_bound(num_connections) ! - real(r8) , intent(out) :: dkdpsi(num_connections,2) ! - real(r8) :: k_up,k_dn - integer :: icnx,id_dn,id_up - integer :: k_arootsoil - real(r8) :: k_bound_aroot_soil1 ! radial conductance ofabsorbing roots [kg s-1 MPa-1] - real(r8) :: k_bound_aroot_soil2 ! conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] -! - integer :: nstep - nstep = get_nstep() - associate( & - z_node => ccohort_hydr%z_node, & - conn_up => ccohort_hydr%conn_up, & - conn_dn => ccohort_hydr%conn_dn, & - cond_up => ccohort_hydr%cond_up, & - cond_dn => ccohort_hydr%cond_dn, & - conductance => ccohort_hydr%conductance & - ) - k_arootsoil = n_hypool_tot-nshell - do icnx = 1, num_connections - id_dn = conn_dn(icnx) - id_up = conn_up(icnx) - hdiff_bound(icnx) = 1.e-6_r8*denh2o*grav*(z_node(id_dn) - z_node(id_up)) + (psi_node(id_dn) - psi_node(id_up)) - dhdpsi(icnx,1) = 1.d0 ! for id_dn - dhdpsi(icnx,2) = -1.d0 ! for id_up - do_kbound_upstream = .true. - if(do_kbound_upstream) then - if(icnx == (k_arootsoil)) then ! absorbing root-1st rhizosphere shell boundary. Comprised of two distinct conductance terms each with distinct water potentials - k_dn = cond_dn(icnx) * flc_node(id_dn) - k_up = cond_up(icnx) * flc_node(id_up) - k_bound(icnx) = 1._r8/(1._r8/k_dn + 1._r8/k_up) - dkdpsi(icnx,1) = ((k_bound(icnx)/k_dn)**2._r8) * cond_dn(icnx)*dflcdpsi_node(id_dn) - dkdpsi(icnx,2) = ((k_bound(icnx)/k_up)**2._r8) * cond_up(icnx)*dflcdpsi_node(id_up) - else - ! examine direction of water flow; use the upstream node's k for - ! the boundary k. (as suggested by Ethan Coon, LANL) - if(hdiff_bound(icnx) < 0._r8) then - k_bound(icnx) = conductance(icnx) * flc_node(id_up) !water moving towards atmosphere - dkdpsi(icnx,1) = 0._r8 - dkdpsi(icnx,2) = conductance(icnx) * dflcdpsi_node(id_up) - else - k_bound(icnx) = conductance(icnx) * flc_node(id_dn) !water moving towards soil - dkdpsi(icnx,1) = conductance(icnx) * dflcdpsi_node(id_dn) - dkdpsi(icnx,2) = 0._r8 - end if - end if - else - k_dn = cond_dn(icnx) * flc_node(id_dn) - k_up = cond_up(icnx) * flc_node(id_up) - k_bound(icnx) = 1._r8/(1._r8/k_dn + 1._r8/k_up) - dkdpsi(icnx,1) = ((k_bound(icnx)/k_dn)**2._r8) * cond_dn(icnx) * dflcdpsi_node(id_dn) - dkdpsi(icnx,2) = ((k_bound(icnx)/k_up)**2._r8) * cond_up(icnx) * dflcdpsi_node(id_up) - end if -! update location - if(icnx == k_arootsoil) & - k_arootsoil = k_arootsoil + nshell + 1 - enddo - end associate - - return -! - end subroutine boundary_hdiff_and_k_alt - ! ===================================================================================== subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & - dtime,qtop, & - sapflow,rootuptake,wb_error_site, nsteps, & - dth_layershell_site, runoff_site) + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant,nsteps, & + dth_layershell_site) ! --------------------------------------------------------------------------------- @@ -4485,67 +4419,75 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! ARGUMENTS: ! ----------------------------------------------------------------------------------- type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(ed_cohort_hydr_type), target :: ccohort_hydr + type(ed_cohort_hydr_type), target :: cohort_hydr type(ed_cohort_type) , intent(inout), target :: cohort type(bc_in_type),intent(in) :: bc_in - real(r8),intent(in) :: dtime + real(r8),intent(in) :: tmx ! time interval to integrate over [s] real(r8),intent(in) :: qtop - real(r8),intent(out) :: sapwflow - real(r8),intent(out) :: rootuptake - integer,intent(out) :: nsteps - real(r8),intent(inout) :: wb_error_site - real(r8),intent(inout) :: dth_layershell_site - real(r8),intent(inout) :: runoff_site - - - integer :: k, ft - integer :: j, icnx - integer :: id_dn, id_up - - real(r8) :: wb_step_err ! water balance error over substep [kg] - real(r8) :: w_tot_beg ! total plant water prior to solve [kg] - real(r8) :: w_tot_end ! total plant water at end of solve [kg] - real(r8) :: dt_substep ! timestep length of substeps [s] - - real(r8) :: qflx ! water flux at current step [kg/s] - ! (from upstream to downstream node +pos) - - integer :: icnv ! Convergence flag for each solve, see flag definitions - ! below. + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + + integer,intent(out) :: nsteps ! Number of rounds of attempts we have made + real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration + ! should match change in storage [kg/m2] + real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] + real(r8),intent(inout) :: dth_layershell_site(:,:) + + + integer :: i ! generic index (sometimes node index) + integer :: inode ! node index + integer :: k ! generic node index + integer :: j, icnx ! soil layer and connection indices + integer :: id_dn, id_up ! Node indices on each side of flux path + integer :: ishell ! rhizosphere shell index + + integer :: icnv ! Convergence flag for each solve, see flag definitions + ! below. - real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" + real(r8) :: dqflx_dpsi_dn ! Derivative, change in mass flux per change + ! in matric potential of the down-stream node + ! [kg s-1 Mpa-1] - real(r8) :: thsatx - real(r8) :: slx - real(r8) :: plx - real(r8) :: dplx - real(r8) :: residual_amax ! maximum absolute mass balance residual over all - ! nodes, - ! used for determining convergence. At the point - - real(r8) :: rsdx ! Temporary residual while determining max value - + real(r8) :: dqflx_dpsi_up ! Derivative, change in mass flux per change + ! in matric potential of the up-stream node + ! [kg s-1 Mpa-1] - real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments - real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents + real(r8) :: dk_dpsi_dn ! change in effective conductance from the + ! downstream pressure node + real(r8) :: dk_dpsi_up ! change in effective conductance from the + ! upstream pressure node - real(r8) :: tm ! Total time integrated after each substep [s] - real(r8) :: tmx ! Total time to be integrated this step [s] + real(r8) :: residual_amax ! maximum absolute mass balance residual over all + ! nodes, + ! used for determining convergence. At the point + + real(r8) :: rsdx ! Temporary residual while determining max value - real(r8) :: dwat_veg_coh - integer :: nsd ! node index in B vector with highest term - integer :: nwtn_iter ! number of (Newton) iterations on each substep - integer :: ntsr ! Number of rounds of attempts we have made - ! to get a succesfull Newton solve. - integer :: kshell ! rhizosphere shell index, 1->nshell + real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments + real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - real(r8) :: sapflow + real(r8) :: tm ! Total time integrated after each substep [s] + real(r8) :: dtime ! Total time to be integrated this step [s] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + + real(r8) :: k_eff ! Effective conductivity over the current pathway + ! between two nodes. Factors in fractional + ! loss of conductivity on each side of the pathway, and the material maximum + ! conductivity on each side [kg/s/MPa] + integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell + + integer :: nsd ! node index of highest residual + integer :: nwtn_iter ! number of (Newton) iterations on each substep + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + integer :: info - integer :: nstep !number of time steps + integer :: nstep !number of time steps ! This is a convergence test. This is the maximum difference @@ -4578,24 +4520,32 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8), parameter :: dtime_rf = 0.2_r8 - - - - associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn, & - kmax_up => site_hydr%kmax_up, & - kmax_dn => site_hydr%kmax_dn, & - residual => site_hydr%residual, & - ajac => site_hydr%ajac, & - ipiv => site_hydr%ipiv, & - th_node => site_hydr%th_node, & - th_node_init => site_hydr%th_node_init, & - psi_node => site_hydr%psi_node, & - pm_node => site_hydr%pm_node, & - ftc_node => site_hydr%ftc_node, & - z_node => site_hydr%z_node, & - v_node => site_hydr%v_node, & - ft => cohort%pft) + real(r8), parameter :: rlfx_soil0 = 0.1 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt0 = 0.6 ! Initial Pressure update + ! reduction factor for plant comparmtents + + + associate(conn_up => site_hydr%conn_up, & + conn_dn => site_hydr%conn_dn, & + kmax_up => site_hydr%kmax_up, & + kmax_dn => site_hydr%kmax_dn, & + q_flux => site_hydr%q_flux, & + residual => site_hydr%residual, & + ajac => site_hydr%ajac, & + ipiv => site_hydr%ipiv, & + th_node => site_hydr%th_node, & + th_node_init => site_hydr%th_node_init, & + psi_node => site_hydr%psi_node, & + pm_node => site_hydr%pm_node, & + ftc_node => site_hydr%ftc_node, & + z_node => site_hydr%z_node, & + v_node => site_hydr%v_node, & + dth_node => site_hydr%dth_node, & + node_layer => site_hydr%node_layer, & + h_node => site_hydr%h_node, & + dftc_dpsi_node => site_hydr%dftc_dpsi_node, & + ft => cohort%pft) !for debug only @@ -4606,6 +4556,17 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & call site_hydr%FlushSiteScratch() + ! These are output fluxes from the subroutine, total integrated + ! mass fluxes [kg] over the time-step. sapflow is the integrated + ! flux between the transporting root and the 1st stem compartment. + ! The rootuptake is the integrated flux between the 1st rhizosphere + ! and absorbing roots + sapflow = 0._r8 + rootuptake = 0._r8 + + ! Chnage in water content, over all substeps [m3/m3] + dth_node(:) = 0._r8 + ! Transfer node heights, volumes and initial water contents for ! the transporting root and above ground compartments to the ! complete node vector @@ -4625,7 +4586,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! Transfer node-heights, volumes and intiial water contents ! for below-ground components, ! from the cohort structures, into the complete node vector - inode = n_hypool_ag + n_hypool_troot + i = n_hypool_ag + n_hypool_troot do j = 1,site_hydr%nlevsoi_hyd @@ -4633,34 +4594,36 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment - aroot_frac_plant = ccohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) do k = 1, n_hypool_aroot + nshell - inode = inode + 1 + i = i + 1 if (k==1) then - z_node(inode) = -bc_in%z_sisl(j) - v_node(inode) = cohort_hydr%v_aroot_layer(j) - th_node_init(inode) = cohort_hydr%th_aroot(j) + z_node(i) = -bc_in%z_sisl(j) + v_node(i) = cohort_hydr%v_aroot_layer(j) + th_node_init(i) = cohort_hydr%th_aroot(j) else kshell = k-1 - z_node(inode) = -bc_in%z_sisl(j) + z_node(i) = -bc_in%z_sisl(j) ! The volume of the Rhizosphere for a single plant - v_node(inode) = site_hydr%v_shell(j,kshell)*aroot_frac_plant - th_node_init(inode) = site_hydr%h2osoi_liqvol_shell(j,kshell) + v_node(i) = site_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) end if enddo enddo + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o + ! Initialize variables and flags that track ! the progress of the solve - tmx = dtime tm = 0 - ntsr = 0 + nsteps = 0 - do while(tm < tmx) + outerloop: do while(tm < tmx) ! If we are here, then we either are starting the solve, ! or, we just completed a solve but did not fully integrate @@ -4669,8 +4632,8 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & dtime = tmx-tm ! Relaxation factors are reset to starting point. - rlfx_plnt = 0.6_r8 - rlfx_soil = 0.1_r8 + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 ! Return here if we want to start a new round of Newton ! iterations. The previous round was unsucessful either @@ -4699,36 +4662,32 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & residual(:) = 0._r8 - do k=1,num_nodes + do k=1,site_hydr%num_nodes ! This is the storage gained from previous newton iterations. residual(k) = residual(k) + (th_node(k) - th_node_init(k))/dtime*denh2o*v_node(k) - if(k <= n_hypool_plant) then + if(pm_node(k) == rhiz_p_media) then - psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) + j = node_layer(k) + psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) ! Get Fraction of Total Conductivity [-] - ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) - ! deriv psi wrt theta - dtheta_dpsi_node(k) = 1._r8/wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) ! deriv ftc wrt psi - dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - + dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + else - j = node_layer(k) - psi_node(k) = wrf_soil(j)%p%psi_from_th(th_node(k)) + psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) ! Get Fraction of Total Conductivity [-] - ftc_node(k) = wkf_soil(j)%p%ftc_from_psi(psi_node(k)) - ! deriv psi wrt theta - dtheta_dpsi_node(k) = 1._r8/wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) ! deriv ftc wrt psi - dftc_dpsi_node(k) = wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - + dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + end if ! Fill the self-term on the Jacobian's diagonal with the @@ -4736,7 +4695,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then ajac(k,k) = denh2o*v_node(k)/ & - (wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) + (site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) else ajac(k,k) = denh2o*v_node(k)/ & (wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) @@ -4751,7 +4710,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) ! calculate boundary fluxes - do icnx=1,num_connections + do icnx=1,site_hydr%num_connections id_dn = conn_dn(icnx) id_up = conn_up(icnx) @@ -4764,34 +4723,33 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! This will get the effective K, and may modify FTC depending ! on the flow direction - + call GetKAndDKDPsi(kmax_dn(icnx), & kmax_up(icnx), & h_node(id_dn), & h_node(id_up), & ftc_node(id_dn), & ftc_node(id_up), & + dftc_dpsi_node(id_dn), & + dftc_dpsi_node(id_up), & dk_dpsi_dn, & dk_dpsi_up, & k_eff) - qflx = k_eff*(h_node(id_up)-h_node(id_dn)) - + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) ! See equation (22) in technical documentation ! Add fluxes at current time to the residual - residual(id_dn) = residual(id_dn) - qflx - residual(id_up) = residual(id_up) + qflx + residual(id_dn) = residual(id_dn) - q_flux(icnx) + residual(id_up) = residual(id_up) + q_flux(icnx) ! This is the Jacobian term related to the pressure changes on the down-stream side ! and these are applied to both the up and downstream sides (oppositely) - dqflx_dpsi_dn = -keff + h_diff * dk_dpsi_dn + dqflx_dpsi_dn = -k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_dn ! This is the Jacobian term related to the pressure changes on the up-stream side ! and these are applied to both the up and downstream sides (oppositely) - ! dqflx_dpsi_up = -1._r8 * (hdiff_bound(icnx) * dkdpsi(icnx,2) + k_bound(icnx)*dhdpsi(icnx,2)) - - dqflx_dpsi_up = keff + h_diff * dk_dpsi_up + dqflx_dpsi_up = k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_up ! Down-stream node's contribution to the down-stream node's Jacobian ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn @@ -4815,8 +4773,11 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & residual(1) = residual(1) + qtop + ! Start off assuming things will pass, then find numerous + ! ways to see if it failed icnv = icnv_pass_round + ! check residual ! if(nstep==15764) print *,'ft,it,residual_amax-',ft,nwtn_iter,residual_amax,'qtop',qtop,psi_node, ! 'init-',psi_node_init,'resi-',residual, 'qflux-',q_flux,'v_n',v_node @@ -4828,7 +4789,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & residual_amax = 0._r8 nsd = 0 - do k = 1, num_nodes + do k = 1, site_hydr%num_nodes rsdx = abs(residual(k)) ! check NaNs if( rsdx /= rsdx ) then @@ -4865,7 +4826,9 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! and perform a Newton iteration else - ! Assume a failed solution unless we find otherwise + ! We wont actually know if we have a good solution + ! until we complete this step and re-calculate the residual + ! so we simply flag that we continue the search icnv = incv_cont_search ! --------------------------------------------------------------------------- @@ -4918,8 +4881,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! singular, so the solution could not be computed. ! --------------------------------------------------------------------------- - call DGESV(num_nodes,1,ajac,num_nodes,ipiv,residual,num_nodes,info) + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + + if ( info < 0 ) then write(fates_log(),*) 'illegal value generated in DGESV() linear' write(fates_log(),*) 'system solver, see node: ',-info @@ -4940,12 +4905,15 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! Update the matric potential of each node. Since this is a search ! we update matric potential as only a fraction of delta psi (residual) - do k = 1, num_nodes - - if(pm_type(k) >= 4) then + do k = 1, site_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then psi_node(k) = psi_node(k) + residual(k) * rlfx_soil + j = node_layer(k) + th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) endif enddo @@ -4958,29 +4926,31 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & write(fates_log(),'(10x,a)') '--- Convergence Failure ---' write(fates_log(),'(4x,a,1pe11.4,2(a,i6),1pe11.4)') 'Equation Maximum Residual = ', & - residual_amax,' Node = ',nsd, 'pft = ',ft, bc_in%qflx_transp_pa(ft) + residual_amax,' Node = ',nsd, 'pft = ',ft, 'qtop: ',qtop ! If we have not exceeded our max number ! of retrying rounds of Newton iterations, reduce ! time and try a new round - if( ntsr < max_newton_rounds ) then + if( nsteps < max_newton_rounds ) then tm = tm - dtime - ntsr = ntsr + 1 + nsteps = nsteps + 1 - dtime_last = dtime - dtime = min(dtime_last * dtime_rf,tmx-tm) + write(fates_log(),*) 'fates hydraulics, MatSolve2D:' + write(fates_log(),'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & + 'Time Step Reduced From ',dtime,'s',' to ', & + min(dtime * dtime_rf,tmx-tm),'s' - - write(*,'(4x,a,1pe11.4,1x,2a,1pe11.4,1x,a)') & - 'Time Step Reduced From ',dtime_last,'s',' to ', & - dtime,'s' - do k = 1,num_nodes - psi_node(k) = psi_node_init(k) + dtime = min(dtime * dtime_rf,tmx-tm) + + do k = 1,site_hydr%num_nodes th_node(k) = th_node_init(k) enddo - rlfx_plnt = 0.6_r8 - rlfx_soil = 0.15_r8 + + ! Decrease the relaxation factors + rlfx_plnt = rlfx_plnt0*(0.9_r8**real(nsteps,r8)) + rlfx_soil = rlfx_soil0*(0.9_r8**real(nsteps,r8)) + ! !--- Number of time step reductions failure: stop simulation --- ! @@ -4989,27 +4959,22 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! iterations with smaller timestepps and relaxations icnv = icnv_complete_fail endif + endif - ! Update water content - do k=1,num_nodes - - if( pm_node(k) == rhiz_p_media ) then - j = node_layer(k) - th_node(k) = wrf_soil(j)%p%th_from_psi(psi_node(k)) - else - th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) - end if - - enddo + if(icnv == icnv_fail_round) then goto 100 elseif(icnv == incv_cont_search) then + + ! THIS MAY BE A GOOD PLACE TO INCREASE + ! THE RELAXATION FACTORS goto 200 + elseif(icnv == icnv_pass_round) then - dth_node(:) = th_node(:) - th_node_init(:) + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) goto 201 elseif(icnv == icnv_complete_fail) then write(fates_log(),*) 'Newton hydraulics solve' @@ -5031,73 +4996,72 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! and need to continue the iteration. 201 continue - - ccohort_hydr%th_ag(1:n_hypool_ag) = th_node(1:n_hypool_ag) - ccohort_hydr%psi_ag(1:n_hypool_ag) = psi_node(1:n_hypool_ag) - ccohort_hydr%flc_ag(1:n_hypool_ag) = flc_node(1:n_hypool_ag) - ccohort_hydr%th_troot(1:n_hypool_troot) = th_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - ccohort_hydr%psi_troot(1:n_hypool_troot) = psi_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - ccohort_hydr%flc_troot(1:n_hypool_troot) = flc_node(n_hypool_ag+1:n_hypool_ag+n_hypool_troot) - dwat_veg_coh = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot)) - num_nds = n_hypool_ag+n_hypool_troot - - do j = 1,site_hydr%nlevsoi_hyd - do k = (n_hypool_ag+n_hypool_troot+1), n_hypool_tot - num_nds = num_nds + 1 - if(k==n_hypool_plant) then - ccohort_hydr%th_aroot(j) = th_node(num_nds) - ccohort_hydr%psi_aroot(j) = psi_node(num_nds) - ccohort_hydr%flc_aroot(j) = flc_node(num_nds) - dwat_veg_coh = dwat_veg_coh + dth_node(num_nds) * v_node(num_nds) - else -! kshell = k-n_hypool_plant -! dth_layershell(j,kshell) = dth_layershell(j,kshell) + & -! (th_node(num_nds) - th_node_init(num_nds)) * & -! ccohort_hydr%l_aroot_layer(j) * & -! ccohort%n /site_hydr%l_aroot_layer(j) * dtime + ! Save flux diagnostics + ! ------------------------------------------------------ - !dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & - ! dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & - ! ccohort_hydr%l_aroot_layer(ilayer) * & - ! ccohort%n / site_hydr%l_aroot_layer(ilayer) + sapflow = sapflow + q_flux(n_hypool_ag)*dtime - - endif - enddo + do j = 1,site_hydr%nlevsoi_hyd + ! Connection betwen the 1st rhizosphere and absorbing roots + icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 + rootuptake = rootuptake + q_flux(icnx_ar)*dtime enddo - dwat_veg_coh = dwat_veg_coh * denh2o - site_hydr%dwat_veg = site_hydr%dwat_veg+ dwat_veg_coh*ccohort%n/AREA!*patch_wgt - site_hydr%h2oveg = site_hydr%h2oveg +dwat_veg_coh*ccohort%n/AREA!*patch_wgt + + + ! If there are any sub-steps left, we need to update + ! the initial water content th_node_init(:) = th_node(:) - psi_node_init(:) = psi_node(:) - enddo + + end do outerloop + + + ! If we have made it here, we have successfully integrated + ! the water content. Transfer this from scratch space + ! into the cohort memory structures for plant compartments, + ! and increment the site-level change in soil moistures + + ! Update state variables in plant compartments + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + + ! Change in water per plant [kg/plant] + dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o - ! Assign the changes to the site level soil water + inode = n_hypool_ag+n_hypool_troot do j = 1,site_hydr%nlevsoi_hyd - do k = n_hypool_plant+1, n_hypool_tot + do k = 1, nshell+1 inode = inode + 1 - kshell = k-n_hypool_plant - - dth_layershell(j,kshell) = dth_layershell(j,kshell) + & - (th_node(inode) - th_node_init(inode)) * & - ccohort_hydr%l_aroot_layer(j) * & - ccohort%n /site_hydr%l_aroot_layer(j) - - end do - end do + if(k==1) then + cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) + dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o + else + ishell = k-1 + dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & + dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & + cohort%n / site_hydr%l_aroot_layer(j) + + endif + enddo + enddo + + ! Total water mass in the plant at the end of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + ! Mass error (flux - change) [kg/m2] + wb_err_plant = (qtop*dtime)-(w_tot_beg-w_tot_end) - end associate + + end associate return end subroutine MatSolve2D ! ===================================================================================== - subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node,aroot_frac_plant, & - kmax_dn,kmax_up) + subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) ! ------------------------------------------------------------------------------- ! This subroutine sets the maximum conductances @@ -5110,10 +5074,8 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node,aroot_frac_plant ! ------------------------------------------------------------------------------- type(ed_site_hydr_type), intent(in),target :: site_hydr - type(ed_cohort_hydr_type), intent(in),target :: ccohort_hydr + type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr real(r8),intent(in) :: h_node(:) ! Total (matric+height) potential at each node (Mpa) - real(r8),intent(in) :: aroot_frac_plant ! Fraction of the total absorbing root mass - ! in the soil taken up by this cohort (/) real(r8),intent(out) :: kmax_dn(:) ! Max conductance of downstream sides of connections (kg s-1 MPa-1) real(r8),intent(out) :: kmax_up(:) ! Max conductance of upstream sides of connections (kg s-1 MPa-1) @@ -5125,8 +5087,8 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node,aroot_frac_plant integer :: k ! rhizosphere/root index (per level) integer :: j ! soil layer index - kmax_dn(:) = fates_unset_real - kmax_up(:) = fates_unset_real + kmax_dn(:) = fates_unset_r8 + kmax_up(:) = fates_unset_r8 ! Set leaf to stem connections (only 1 leaf layer ! this will break if we have multiple, as there would @@ -5150,7 +5112,7 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node,aroot_frac_plant ! Path is between the transporting root and the absorbing roots inode = n_hypool_ag - do j = 1,site_hydr%nlevsoil_hyd + do j = 1,site_hydr%nlevsoi_hyd aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7cdf74fdd9..3e265955d0 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3353,16 +3353,16 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & (ccohort_hydr%qtop) * number_fraction_rate ! [kg/indiv/s] - hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & - sum(ccohort_hydr%rootuptake) * number_fraction_rate ! [kg/indiv/s] +! hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & +! sum(ccohort_hydr%rootuptake) * number_fraction_rate ! [kg/indiv/s] - do j=1,sites(s)%si_hydr%nlevsoi_hyd - hio_rootuptake_sl(io_si,j) = hio_rootuptake_sl(io_si,j) + & - ccohort_hydr%rootuptake(j) * number_fraction_rate ! [kg/indiv/s] - end do +! do j=1,sites(s)%si_hydr%nlevsoi_hyd +! hio_rootuptake_sl(io_si,j) = hio_rootuptake_sl(io_si,j) + & +! ccohort_hydr%rootuptake(j) * number_fraction_rate ! [kg/indiv/s] +! end do - hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & - ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] +! hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & +! ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & ccohort_hydr%iterh1 * number_fraction ! [-] @@ -5003,25 +5003,25 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) - call this%set_history_var(vname='FATES_ROOTUPTAKE_SCPF', units='kg/indiv/s', & - long='mean individual root uptake rate', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) +! call this%set_history_var(vname='FATES_ROOTUPTAKE_SCPF', units='kg/indiv/s', & +! long='mean individual root uptake rate', use_default='inactive', & +! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) - call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg/indiv/s', & - long='mean individual root uptake rate per layer', use_default='inactive', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) +! call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg/indiv/s', & +! long='mean individual root uptake rate per layer', use_default='inactive', & +! avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) call this%set_history_var(vname='FATES_H2OSOI_COL_SHSL', units='m3/m3', & long='volumetric soil moisture by layer and shell', use_default='inactive', & avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2osoi_si_scagpft ) - call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & - long='individual sap flow rate', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) +! call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & +! long='individual sap flow rate', use_default='inactive', & +! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) call this%set_history_var(vname='FATES_ITERH1_COL_SCPF', units='count/indiv/step', & long='number of outer iterations required to achieve tolerable water balance error', & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 6e7627ea47..65971075bb 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -133,6 +133,17 @@ module FatesHydraulicsMemMod ! insufficient plant water available to ! support transpiration + + ! Useful diagnostics + ! ---------------------------------------------------------------------------------- + +!! real(r8),allocatable :: sapflow(:,:) ! flow at base of tree (+ upward) [kg/cohort/s] +!! real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/cohort/s] + + + + + class(wrf_arr_type), pointer :: wrf_soil(:) ! Water retention function for soil layers class(wkf_arr_type), pointer :: wkf_soil(:) ! Water conductivity (K) function for soil @@ -141,10 +152,30 @@ module FatesHydraulicsMemMod ! and type map for the whole system of compartments, from the soil to leaf ! as one vector - integer, protected :: num_connections - integer, allocatable, protected :: conn_up(:) - integer, allocatable, protected :: conn_dn(:) - integer, allocatable, protected :: pm_type(:) + integer :: num_connections + integer :: num_nodes + integer, allocatable :: conn_up(:) + integer, allocatable :: conn_dn(:) + integer, allocatable :: pm_node(:) + integer, allocatable :: node_layer(:) + integer, allocatable :: ipiv(:) ! unused, returned from DSEGV + + real(r8), allocatable :: residual(:) + real(r8), allocatable :: ajac(:,:) + real(r8), allocatable :: th_node_init(:) + real(r8), allocatable :: th_node(:) + real(r8), allocatable :: dth_node(:) + real(r8), allocatable :: h_node(:) + real(r8), allocatable :: v_node(:) + real(r8), allocatable :: z_node(:) + real(r8), allocatable :: psi_node(:) + real(r8), allocatable :: q_flux(:) + real(r8), allocatable :: dftc_dpsi_node(:) + real(r8), allocatable :: ftc_node(:) + + + real(r8), allocatable :: kmax_up(:) + real(r8), allocatable :: kmax_dn(:) contains @@ -232,6 +263,9 @@ module FatesHydraulicsMemMod real(r8) :: btran ! leaf water potential limitation on gs [0-1] + real(r8) :: qtop ! mean transpiration flux rate [kg/cohort/s] + + ! Variables used for error tracking and flagging ! ---------------------------------------------------------------------------------- @@ -261,12 +295,7 @@ module FatesHydraulicsMemMod - ! Useful diagnostics - ! ---------------------------------------------------------------------------------- - real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] - real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/indiv/timestep] - real(r8) :: qtop ! mean transpiration flux rate [kg/indiv/timestep] ! Other ! ---------------------------------------------------------------------------------- @@ -315,7 +344,7 @@ subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) allocate(this%th_aroot(1:nlevsoil_hydr)) allocate(this%psi_aroot(1:nlevsoil_hydr)) allocate(this%ftc_aroot(1:nlevsoil_hydr)) - allocate(this%rootuptake(1:nlevsoil_hydr)) +! allocate(this%rootuptake(1:nlevsoil_hydr)) return end subroutine AllocateHydrCohortArrays @@ -337,7 +366,7 @@ subroutine DeallocateHydrCohortArrays(this) deallocate(this%th_aroot) deallocate(this%psi_aroot) deallocate(this%ftc_aroot) - deallocate(this%rootuptake) +! deallocate(this%rootuptake) return end subroutine DeallocateHydrCohortArrays @@ -349,22 +378,22 @@ subroutine InitHydrSite(this) ! Arguments class(ed_site_hydr_type),intent(inout) :: this - associate( nlevsoil_hyd => this%nlevsoi_hyd ) + associate( nlevsoil_hydr => this%nlevsoi_hyd ) - allocate(this%v_shell(1:nlevsoil_hyd,1:nshell)) ; this%v_shell = nan - allocate(this%v_shell_init(1:nlevsoil_hyd,1:nshell)) ; this%v_shell_init = nan - allocate(this%r_node_shell(1:nlevsoil_hyd,1:nshell)) ; this%r_node_shell = nan - allocate(this%r_node_shell_init(1:nlevsoil_hyd,1:nshell)); this%r_node_shell_init = nan - allocate(this%r_out_shell(1:nlevsoil_hyd,1:nshell)) ; this%r_out_shell = nan - allocate(this%l_aroot_layer(1:nlevsoil_hyd)) ; this%l_aroot_layer = nan - allocate(this%l_aroot_layer_init(1:nlevsoil_hyd)) ; this%l_aroot_layer_init = nan - allocate(this%kmax_upper_shell(1:nlevsoil_hyd,1:nshell)); this%kmax_upper_shell = nan - allocate(this%kmax_lower_shell(1:nlevsoil_hyd,1:nshell)); this%kmax_lower_shell = nan - allocate(this%supsub_flag(1:nlevsoil_hyd)) ; this%supsub_flag = -999 - allocate(this%h2osoi_liqvol_shell(1:nlevsoil_hyd,1:nshell)) ; this%h2osoi_liqvol_shell = nan - allocate(this%h2osoi_liq_prev(1:nlevsoil_hyd)) ; this%h2osoi_liq_prev = nan - allocate(this%rs1(1:nlevsoil_hyd)); this%rs1(:) = fine_root_radius_const - allocate(this%recruit_w_uptake(1:nlevsoil_hyd)); this%recruit_w_uptake = nan + allocate(this%v_shell(1:nlevsoil_hydr,1:nshell)) ; this%v_shell = nan + allocate(this%v_shell_init(1:nlevsoil_hydr,1:nshell)) ; this%v_shell_init = nan + allocate(this%r_node_shell(1:nlevsoil_hydr,1:nshell)) ; this%r_node_shell = nan + allocate(this%r_node_shell_init(1:nlevsoil_hydr,1:nshell)); this%r_node_shell_init = nan + allocate(this%r_out_shell(1:nlevsoil_hydr,1:nshell)) ; this%r_out_shell = nan + allocate(this%l_aroot_layer(1:nlevsoil_hydr)) ; this%l_aroot_layer = nan + allocate(this%l_aroot_layer_init(1:nlevsoil_hydr)) ; this%l_aroot_layer_init = nan + allocate(this%kmax_upper_shell(1:nlevsoil_hydr,1:nshell)); this%kmax_upper_shell = nan + allocate(this%kmax_lower_shell(1:nlevsoil_hydr,1:nshell)); this%kmax_lower_shell = nan + allocate(this%supsub_flag(1:nlevsoil_hydr)) ; this%supsub_flag = -999 + allocate(this%h2osoi_liqvol_shell(1:nlevsoil_hydr,1:nshell)) ; this%h2osoi_liqvol_shell = nan + allocate(this%h2osoi_liq_prev(1:nlevsoil_hydr)) ; this%h2osoi_liq_prev = nan + allocate(this%rs1(1:nlevsoil_hydr)); this%rs1(:) = fine_root_radius_const + allocate(this%recruit_w_uptake(1:nlevsoil_hydr)); this%recruit_w_uptake = nan this%errh2o_hyd = nan this%dwat_veg = nan @@ -377,16 +406,16 @@ subroutine InitHydrSite(this) ! We have separate water transfer functions and parameters ! for each soil layer, and each plant compartment type - allocate(this%wrf_soil(1:nlevsoil_hyd)) - allocate(this%wkf_soil(1:nlevsoil_hyd)) + allocate(this%wrf_soil(1:nlevsoil_hydr)) + allocate(this%wkf_soil(1:nlevsoil_hydr)) if(use_2d_hydrosolve) then this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & - + (n_hypool_aroot + nshell) * nlevsoil_hyd + + (n_hypool_aroot + nshell) * nlevsoil_hydr this%num_nodes = n_hypool_leaf + n_hypool_stem + n_hypool_troot & - + (n_hypool_aroot + nshell) * nlevsoil_hyd + + (n_hypool_aroot + nshell) * nlevsoil_hydr ! These are only in the newton-matrix solve allocate(this%conn_up(this%num_connections)) @@ -395,13 +424,21 @@ subroutine InitHydrSite(this) allocate(this%ajac(this%num_nodes,this%num_nodes)) allocate(this%th_node_init(this%num_nodes)) allocate(this%th_node(this%num_nodes)) + allocate(this%dth_node(this%num_nodes)) allocate(this%v_node(this%num_nodes)) allocate(this%z_node(this%num_nodes)) allocate(this%psi_node(this%num_nodes)) allocate(this%q_flux(this%num_connections)) + allocate(this%dftc_dpsi_node(this%num_nodes)) + allocate(this%ftc_node(this%num_nodes)) allocate(this%pm_node(this%num_nodes)) + allocate(this%ipiv(this%num_nodes)) + allocate(this%node_layer(this%num_nodes)) - else + allocate(this%kmax_up(this%num_connections)) + allocate(this%kmax_dn(this%num_connections)) + + else this%num_connections = n_hypool_leaf + n_hypool_stem + & n_hypool_troot + n_hypool_aroot + nshell -1 @@ -414,28 +451,34 @@ subroutine InitHydrSite(this) allocate(this%pm_node(this%num_nodes)) - end if + end if end associate - + return - end subroutine InitHydrSite - + end subroutine InitHydrSite + ! =================================================================================== subroutine FlushSiteScratch(this) class(ed_site_hydr_type),intent(inout) :: this if(use_2d_hydrosolve) then - residual(:) = fates_unset_r8 - ajac(:,:) = fates_unset_r8 - th_node_init(:) = fates_unset_r8 - th_node(:) = fates_unset_r8 - v_node(:) = fates_unset_r8 - z_node(:) = fates_unset_r8 - psi_node(:) = fates_unset_r8 + this%residual(:) = fates_unset_r8 + this%ajac(:,:) = fates_unset_r8 + this%th_node_init(:) = fates_unset_r8 + this%th_node(:) = fates_unset_r8 + this%dth_node(:) = fates_unset_r8 + this%h_node(:) = fates_unset_r8 + this%v_node(:) = fates_unset_r8 + this%z_node(:) = fates_unset_r8 + this%psi_node(:) = fates_unset_r8 + this%ftc_node(:) = fates_unset_r8 + this%dftc_dpsi_node(:) = fates_unset_r8 +! this%kmax_up(:) = fates_unset_r8 +! this%kmax_dn(:) = fates_unset_r8 + this%q_flux(:) = fates_unset_r8 end if - end subroutine FlushSiteScratch @@ -449,6 +492,7 @@ subroutine SetConnections(this) integer :: num_cnxs integer :: num_nds integer :: nt_ab + integer :: node_tr_end num_cnxs = 0 num_nds = 0 @@ -457,14 +501,14 @@ subroutine SetConnections(this) num_nds = num_nds + 1 this%conn_dn(num_cnxs) = k !leaf is the dn, origin, bottom this%conn_up(num_cnxs) = k + 1 - this%pm_type(num_nds) = leaf_p_media + this%pm_node(num_nds) = leaf_p_media enddo do k = n_hypool_leaf+1, n_hypool_ag num_cnxs = num_cnxs + 1 num_nds = num_nds + 1 this%conn_dn(num_cnxs) = k this%conn_up(num_cnxs) = k+1 - this%pm_type(num_nds) = stem_p_media + this%pm_node(num_nds) = stem_p_media enddo if(use_2d_hydrosolve) then @@ -474,29 +518,32 @@ subroutine SetConnections(this) nt_ab = n_hypool_ag+n_hypool_troot+n_hypool_aroot num_cnxs = n_hypool_ag - this%pm_type(num_nds) = troot_p_media + this%pm_node(num_nds) = troot_p_media + this%node_layer(1:n_hypool_ag) = 0 + this%node_layer(num_nds) = 1 - do j = 1,this%nlevsoil_hyd + do j = 1,this%nlevsoi_hyd do k = 1, n_hypool_aroot + nshell num_nds = num_nds + 1 num_cnxs = num_cnxs + 1 + this%node_layer(num_nds) = j if( k == 1 ) then !troot-aroot !junction node this%conn_dn(num_cnxs) = node_tr_end !absorbing root this%conn_up(num_cnxs) = num_nds - this%pm_type(num_nds) = aroot_p_media + this%pm_node(num_nds) = aroot_p_media else this%conn_dn(num_cnxs) = num_nds - 1 this%conn_up(num_cnxs) = num_nds - this%pm_type(num_nds) = rhiz_p_media + this%pm_node(num_nds) = rhiz_p_media endif enddo end do else - - this%pm_type(num_hypool_ag+1) = troot_p_media - this%pm_type(num_hypool_ag+2) = aroot_p_media - this%pm_type(num_hypool_ag+3:num_hypool_ag+2+nshell) = rhiz_p_media + + this%pm_node(n_hypool_ag+1) = troot_p_media + this%pm_node(n_hypool_ag+2) = aroot_p_media + this%pm_node(n_hypool_ag+3:n_hypool_ag+2+nshell) = rhiz_p_media end if From 69de8531aedc3ae9e832bafd9c88452ff6908244 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 6 Feb 2020 12:25:36 -0800 Subject: [PATCH 057/114] fates-hydraulics: debugging, checking WTFs --- biogeophys/FatesHydroWTFMod.F90 | 43 +++++++++++++++---------- biogeophys/FatesPlantHydraulicsMod.F90 | 44 +++++++++++++++++++------- main/FatesHistoryInterfaceMod.F90 | 12 +++---- main/FatesHydraulicsMemMod.F90 | 8 +++-- main/FatesInterfaceMod.F90 | 3 ++ 5 files changed, 75 insertions(+), 35 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 512162f2ca..4ca838206b 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -268,6 +268,8 @@ function th_from_psi_vg(this,psi) result(th) ! satfrac = (1._r8 + (-this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) + +! print*,'satfrac: ',satfrac ! convert to volumetric water content th = satfrac*(this%th_sat-this%th_res) + this%th_res @@ -299,31 +301,39 @@ function psi_from_th_vg(this,th) result(psi) m = 1._r8/this%psd satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + +!! if(satfrac>max_rwc_interp) then - if(satfrac>max_rwc_interp) then - - th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res - dpsidth_interp = this%dpsidth_from_th(th_interp) - psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m - psi = psi_interp + dpsidth_interp*(th-th_interp) +!! th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res +!! dpsidth_interp = this%dpsidth_from_th(th_interp) +!! psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m +!! psi = psi_interp + dpsidth_interp*(th-th_interp) - elseif(satfrac cc_p ccohort_hydr => cCohort%co_hydr csite => site_p @@ -446,10 +448,12 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ccohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_aroot(j)) + psi_rev = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do - + !initialize plant water potentials at hydrostatic equilibrium (dh/dz = 0) !the assumption is made here that initial conditions for soil water will !be in (or at least close to) hydrostatic equilibrium as well, so that @@ -1315,7 +1319,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + ! ----------------------------------------------------------------------------------- ! Initialize the Water Conductance (K) Functions ! ----------------------------------------------------------------------------------- @@ -3161,6 +3165,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & sapflow = 0._r8 rootuptake = 0._r8 + ft = cohort%pft ! ----------------------------------------------------------------------------------- ! As mentioned when calling this routine, we calculate a solution to the flux @@ -3206,7 +3211,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & wb_err_layer = 0._r8 - ft = cohort%pft + ! If in "spatially parallel" mode, scale down cross section ! of flux through top by the root fraction of this layer @@ -3472,9 +3477,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Path is between rhizosphere shells - print*,"THESE SHOULD BE THE SAME: ",(n_hypool_ag+2)-(n_hypool_tot-nshell) - stop - do j = n_hypool_ag+3,n_hypool_tot-1 i_up = j @@ -4612,6 +4614,8 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo enddo + + ! Total water mass in the plant at the beginning of this solve [kg h2o] w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o @@ -4629,7 +4633,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! or, we just completed a solve but did not fully integrate ! the time. Lets update the time-step to be the remainder ! of the step. - dtime = tmx-tm + dtime = min(tmx*0.01,tmx-tm) ! Relaxation factors are reset to starting point. rlfx_plnt = rlfx_plnt0 @@ -4671,6 +4675,16 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & j = node_layer(k) psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) +!! if ( abs(th_node(k)-site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k))) > nearzero) then +!! print*,'non-reversible WRTs?' +!! print*,psi_node(k) +!! print*,th_node(k) +!! print*,site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) +!! stop +!! end if + + + ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) ! Get Fraction of Total Conductivity [-] @@ -4703,6 +4717,12 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & enddo +! do i=1,site_hydr%num_nodes +! print*,i,node_layer(i),pm_node(i),z_node(i),v_node(i),th_node_init(i),psi_node(i),h_node(i) +! end do +! stop + + ! Calculations of maximum conductance for upstream and downstream sides ! of each connection. This IS dependant on total potential h_node ! because of the root-soil radial conductance. @@ -4910,8 +4930,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then psi_node(k) = psi_node(k) + residual(k) * rlfx_soil j = node_layer(k) + print*,'psi:',psi_node(k),k,j th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else + print*,'psi:',psi_node(k),k psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) endif @@ -5138,8 +5160,8 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_u kmax_up(icnx) = site_hydr%kmax_upper_shell(j,1)*aroot_frac_plant else ! soil - soil - kmax_dn(icnx) = site_hydr%kmax_lower_shell(j,k-1)*aroot_frac_plant - kmax_up(icnx) = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_dn(icnx) = site_hydr%kmax_lower_shell(j,k-2)*aroot_frac_plant + kmax_up(icnx) = site_hydr%kmax_upper_shell(j,k-1)*aroot_frac_plant endif enddo diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index a9b06f8689..be04a48a5d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -424,10 +424,10 @@ module FatesHistoryInterfaceMod integer :: ih_errh2o_scpf integer :: ih_tran_scpf - integer :: ih_rootuptake_scpf - integer :: ih_rootuptake_sl +! integer :: ih_rootuptake_scpf +! integer :: ih_rootuptake_sl integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension - integer :: ih_sapflow_scpf +! integer :: ih_sapflow_scpf integer :: ih_iterh1_scpf integer :: ih_iterh2_scpf integer :: ih_supsub_scpf @@ -3272,10 +3272,10 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & - hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & - hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & +! hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & +! hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & - hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & +! hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 65971075bb..ef855fb698 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .false. + logical, parameter, public :: use_2d_hydrosolve = .true. ! Number of soil layers for indexing cohort fine root quanitities @@ -425,6 +425,7 @@ subroutine InitHydrSite(this) allocate(this%th_node_init(this%num_nodes)) allocate(this%th_node(this%num_nodes)) allocate(this%dth_node(this%num_nodes)) + allocate(this%h_node(this%num_nodes)) allocate(this%v_node(this%num_nodes)) allocate(this%z_node(this%num_nodes)) allocate(this%psi_node(this%num_nodes)) @@ -452,7 +453,10 @@ subroutine InitHydrSite(this) end if - + + call this%SetConnections() + + end associate return diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c57a474680..b7a1b21167 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -977,10 +977,13 @@ subroutine zero_bcs(this,s) if (hlm_use_planthydro.eq.itrue) then this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 + end if this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 this%bc_out(s)%qflx_ro_si = 0.0_r8 + print*,"ZEROING BCOUT" + return end subroutine zero_bcs From 2b5970873e057cf517342ff27ec6f572418b46b6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 6 Feb 2020 15:39:59 -0800 Subject: [PATCH 058/114] hydro-wtf test updates --- biogeophys/FatesPlantHydraulicsMod.F90 | 3 + .../hydro/AutoGenVarCon.py | 185 ------------------ .../hydro/HydroUTestDriver.py | 126 +++--------- .../hydro/build_hydro_f90_objects.sh | 16 +- .../hydro/f90_src/HydroUnitWrapMod.F90 | 2 +- .../hydro/f90_src/UnitWrapMod.F90 | 49 +++++ 6 files changed, 85 insertions(+), 296 deletions(-) delete mode 100644 functional_unit_testing/hydro/AutoGenVarCon.py create mode 100644 functional_unit_testing/hydro/f90_src/UnitWrapMod.F90 diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 0cd3988d3c..7f5fbc2eeb 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1300,6 +1300,9 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- + print*,bc_in(s)%watsat_sisl(:) + stop + select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevsoi_hyd diff --git a/functional_unit_testing/hydro/AutoGenVarCon.py b/functional_unit_testing/hydro/AutoGenVarCon.py deleted file mode 100644 index 3288f9280a..0000000000 --- a/functional_unit_testing/hydro/AutoGenVarCon.py +++ /dev/null @@ -1,185 +0,0 @@ -# ============================================================================= -# Walk through lines of a file, if a line contains -# the string of interest (EDPftvarcon_inst), then -# parse the string to find the variable name, and save that -# to the list -# ============================================================================= - -import imp -import code # For development: code.interact(local=dict(globals(), **locals())) - -F90ParamParse = imp.load_source('F90ParamParse','../shared/py_src/F90ParamParse.py') -CDLParse = imp.load_source('CDLParse','../shared/py_src/CDLParse.py') - - -from F90ParamParse import f90_param_type, GetSymbolUsage, GetPFTParmFileSymbols, MakeListUnique -from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type - - -# ------------------------------------------------------------------------------------- -# Check through the fortran Code we are coupling with, determine the list of parameters -# that we need. -# The procedure GetSymbolUsage() returns a list of strings (non-unique) -# ------------------------------------------------------------------------------------- - -check_str = 'pft_p%' -var_list0 = GetSymbolUsage('../../biogeophys/FatesHydroUnitFunctionsMod.F90',check_str) - -# This is the unique list of PFT parameters found in the salient Fortran code - -var_list = MakeListUnique(var_list0) - -# Now look through EDPftvarcon.F90 to determine the variable name in file -# that is associated with the variable pointer - -var_list = GetPFTParmFileSymbols(var_list,'../../main/EDPftvarcon.F90') - -#var_list.append(f90_param_type('parteh_mode')) -#var_list[-1].var_name = 'fates_parteh_mode' - - -# ------------------------------------------------------------- -# We can now cross reference our list of parameters against -# the parameter file. This will create a new list of parameters -# however in the form of a dictionary. This dictionary of -# entries is accessible by its symbol name, and will also -# read in and store the actual parameter values from the file. -# We will use the default file to get the dimensionality. -# -# NOTE: THE CDLPARSE PROCEDURE WILL LOAD IN THE DATA, -# BUT WE DONT NEED IT. THE CDLPARSE PARAM ROUTINE -# IS JUST USED TO GET THE CORRECT DIMENSIONS. THUS WE -# CAN JUST POINT TO THE DEFAULT CDL FILE IN VERSION CONTROL -# -# ------------------------------------------------------------- - - -default_file_relpath = '../../parameter_files/fates_params_default.cdl' - -dims = CDLParseDims(default_file_relpath) - -parms = {} -for elem in var_list: - parms[elem.var_sym] = CDLParseParam(default_file_relpath,cdl_param_type(elem.var_name),dims) - print('Finished loading PFT parameters') - - - -f = open("../shared/f90_src/UnitWrapMod.F90_in", "r") -contents = f.readlines() -f.close() - -# ADD ARGUMENTS TO EDPFTVARCONALLOC -# --------------------------------- - -for i,str in enumerate(contents): - if 'ARGUMENT_IN1' in str: - index0=i - -str='' -icount=0 -for key, value in dims.iteritems(): - print('{}'.format(key)) - if(icount==0): - str+=key - else: - str+=(', & \n '+key) - icount+=1 - -strsplit = contents[index0].split('ARGUMENT_IN1') -strreplace = strsplit[0]+str+strsplit[1] - -contents[index0] = strreplace - - -for i,str in enumerate(contents): - if 'ARGUMENT_DEF1' in str: - index0=i - -str='' -for key, value in dims.iteritems(): - str+=(' integer,intent(in) :: '+key+'\n') - - -contents[index0] = str - - - - - -# Identify where we define the variables, and insert the variable definitions - -for i,str in enumerate(contents): - if 'VARIABLE-DEFINITIONS-HERE' in str: - index0=i - -index=index0+2 -for symbol, var in parms.iteritems(): - - if(var.ndims==1): - contents.insert(index,' real(r8),pointer :: {}(:)\n'.format(symbol)) - elif(var.ndims==2): - contents.insert(index,' real(r8),pointer :: {}(:,:)\n'.format(symbol)) - else: - print('Incorrect number of dims...') - exit(-2) - index=index+1 - -# Identify where we do the pointer assignments, and insert the pointer assignments - - -for i,str in enumerate(contents): - if 'POINTER-SPECIFICATION-HERE' in str: - index0=i - -index=index0+2 -for symbol, var in parms.iteritems(): - - # Generate the dimension names - - dim_alloc_str='' - icount=0 - for dimname in reversed(var.dim_namelist): - if(icount==0): - dim_alloc_str+=dimname - else: - dim_alloc_str+=(','+dimname) - icount+=1 - - - if(var.ndims==1): - ins_l1='\t allocate(EDPftvarcon_inst%{}({}))\n'.format(symbol,dim_alloc_str) - ins_l2='\t EDPftvarcon_inst%{}(:) = fates_unset_r8\n'.format(symbol) - ins_l3='\t iv1 = iv1 + 1\n' - ins_l4='\t EDPftvarcon_ptr%var1d(iv1)%var_name = "{}"\n'.format(var.symbol) - ins_l5='\t EDPftvarcon_ptr%var1d(iv1)%var_rp => EDPftvarcon_inst%{}\n'.format(symbol) - ins_l6='\t EDPftvarcon_ptr%var1d(iv1)%vtype = 1\n' - ins_l7='\n' - elif(var.ndims==2): - ins_l1='\t allocate(EDPftvarcon_inst%{}({}))\n'.format(symbol,dim_alloc_str) - ins_l2='\t EDPftvarcon_inst%{}(:,:) = fates_unset_r8\n'.format(symbol) - ins_l3='\t iv2 = iv2 + 1\n' - ins_l4='\t EDPftvarcon_ptr%var2d(iv2)%var_name = "{}"\n'.format(var.symbol) - ins_l5='\t EDPftvarcon_ptr%var2d(iv2)%var_rp => EDPftvarcon_inst%{}\n'.format(symbol) - ins_l6='\t EDPftvarcon_ptr%var2d(iv2)%vtype = 1\n' - ins_l7='\n' - else: - print('Auto-generating FORTRAN parameter code does not handle >2D') - print(symbol) - print(var.ndims) - exit(2) - - contents.insert(index,ins_l1) - contents.insert(index+1,ins_l2) - contents.insert(index+2,ins_l3) - contents.insert(index+3,ins_l4) - contents.insert(index+4,ins_l5) - contents.insert(index+5,ins_l6) - contents.insert(index+6,ins_l7) - index=index+7 - - -f = open("f90_src/UnitWrapMod.F90", "w+") -contents = "".join(contents) -f.write(contents) -f.close() diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 21eef78b0f..eaa69b00c8 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -37,9 +37,8 @@ # Load the fortran objects via CTYPES -f90_edparams_obj = ctypes.CDLL('bld/EDParamsHydroMod.o',mode=ctypes.RTLD_GLOBAL) -f90_constants_obj = ctypes.CDLL('bld/FatesConstantsMod.o',mode=ctypes.RTLD_GLOBAL) f90_unitwrap_obj = ctypes.CDLL('bld/UnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) +f90_constants_obj = ctypes.CDLL('bld/FatesConstantsMod.o',mode=ctypes.RTLD_GLOBAL) f90_wftfuncs_obj = ctypes.CDLL('bld/FatesHydroWTFMod.o',mode=ctypes.RTLD_GLOBAL) f90_hydrounitwrap_obj = ctypes.CDLL('bld/HydroUnitWrapMod.o',mode=ctypes.RTLD_GLOBAL) @@ -70,6 +69,11 @@ pm_aroot = 4 pm_rhiz = 5 +# These parameters are matched with the indices in FATES-HYDRO +vg_type = 1 +camp_type = 2 +tfs_type = 3 + isoil1 = 0 # Top soil layer parameters (@BCI) isoil2 = 1 # Bottom soil layer parameters @@ -111,99 +115,26 @@ def main(argv): args = parser.parse_args() - - # ------------------------------------------------------------------------------------- - # Check through the fortran Code we are coupling with, determine the list of parameters - # that we need. - # The procedure GetSymbolUsage() returns a list of strings (non-unique) - # ------------------------------------------------------------------------------------- - - check_str = 'pft_p%' - var_list0 = GetSymbolUsage('../../biogeophys/FatesHydroUnitFunctionsMod.F90',check_str) - - # This is the unique list of PFT parameters found in the salient Fortran code - - var_list = MakeListUnique(var_list0) - - # Now look through EDPftvarcon.F90 to determine the variable name in file - # that is associated with the variable pointer - - var_list = GetPFTParmFileSymbols(var_list,'../../main/EDPftvarcon.F90') - - # ------------------------------------------------------------- - # We can now cross reference our list of parameters against - # the parameter file. This will create a new list of parameters - # however in the form of a dictionary. This dictionary of - # entries is accessible by its symbol name, and will also - # read in and store the actual parameter values from the file. - # ------------------------------------------------------------- - - dims = CDLParseDims(args.cdlfile) - pftparms = {} - for elem in var_list: - pftparms[elem.var_sym] = CDLParseParam(args.cdlfile,cdl_param_type(elem.var_name),dims) - print('Finished loading PFT parameters') - - num_pfts = dims['fates_pft'] - - scalarparms = {} - scalarparms['hydr_psi0'] = CDLParseParam(args.cdlfile,cdl_param_type('fates_hydr_psi0'),dims) - scalarparms['hydr_psicap'] = CDLParseParam(args.cdlfile,cdl_param_type('fates_hydr_psicap'),dims) - - - - - # Allocate PFT arrays in the fortran objects - iret=f90_unitwrap_obj.__edpftvarcon_MOD_edpftvarconalloc(ci(dims['fates_string_length']), \ - ci(dims['fates_history_size_bins']), \ - ci(dims['fates_NCWD']), \ - ci(dims['fates_prt_organs']), \ - ci(dims['fates_litterclass']), \ - ci(dims['fates_history_height_bins']), \ - ci(dims['fates_history_age_bins']), \ - ci(dims['fates_hydr_organs']), \ - ci(dims['fates_pft']), \ - ci(dims['fates_variants']), \ - ci(dims['fates_leafage_class'])) - - - - # Set the PFT arrays - for pft_key,pft_obj in pftparms.iteritems(): - for idim in range(np.int(np.prod(pft_obj.dim_sizelist))): - if(pft_obj.ndims==1): - idim1 = idim - idim2 = 0 - rdata = pft_obj.data[idim] - idata = np.int(pft_obj.data[idim]) - else: - idim2 = np.mod(idim,num_pfts) - idim1 = np.int(idim/num_pfts) - rdata = pft_obj.data[idim1,idim2] - idata = np.int(pft_obj.data[idim1,idim2]) - iret = f90_unitwrap_obj.__edpftvarcon_MOD_edpftvarconpyset(c8(rdata), \ - ci(idata), \ - ci(idim2+1), \ - ci(idim1+1), \ - c_char_p(pft_obj.symbol.strip()), \ - c_long(len(pft_obj.symbol.strip()))) - # Set number of analysis points npts = 1000 # min_theta = np.full(shape=(2),dtype=np.float64,fill_value=np.nan) - th_ress = [0.10, 0.20, 0.30, 0.40] + wrf_type = [vg_type, vg_type, vg_type, vg_type] + wkf_type = [vg_type, tfs_type, tfs_type, tfs_type] + th_ress = [0.10, 0.10, 0.20, 0.20] th_sats = [0.65, 0.65, 0.65, 0.65] alphas = [1.0, 1.0, 1.0, 1.0] psds = [2.7, 2.7, 2.7, 2.7] tort = [0.5, 0.5, 0.5, 0.5] + avuln = [2.0, 2.0, 2.5, 2.5] p50 = [-1.5, -1.5, -2.25, -2.25] ncomp= 4 - + # th_sat at BCI over depth: + #0.56664478523835027 0.54903922349686018 0.52782093380496897 0.50773092378032358 0.49398759255861308 0.49059926489050931 0.47927357530747811 0.47244878323265993 0.47244878323265993 0.44112000000000001 0.44112000000000001 0.44112000000000001 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 # Allocate memory to our objective classes iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) @@ -213,16 +144,16 @@ def main(argv): # ------------------------------------------------------------------------- # Generic VGs init_wrf_args = [alphas[0],psds[0],th_sats[0],th_ress[0]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(1),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + iret = setwrf(ci(1),ci(wrf_type[0]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) init_wrf_args = [alphas[1],psds[1],th_sats[1],th_ress[1]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(2),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + iret = setwrf(ci(2),ci(wrf_type[1]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) init_wrf_args = [alphas[2],psds[2],th_sats[2],th_ress[2]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(3),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + iret = setwrf(ci(3),ci(wrf_type[2]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) init_wrf_args = [alphas[3],psds[3],th_sats[3],th_ress[3]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(4),ci(1),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + iret = setwrf(ci(4),ci(wrf_type[3]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) print('initialized WRF') @@ -238,14 +169,16 @@ def main(argv): psi[ic,i] = psi_from_th(ci(ic+1),c8(th)) + # Theta vs psi plots + fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): ax1.plot(theta,psi[ic,:]) - ax1.set_ylim((-10,5)) + ax1.set_ylim((-30,5)) ax1.set_ylabel('Matric Potential [MPa]') ax1.set_xlabel('VWC [m3/m3]') - + ax1.legend(loc='lower right') for ic in range(ncomp): for i in range(1,len(theta)-1): @@ -253,6 +186,8 @@ def main(argv): cdpsidth[ic,i] = (psi[ic,i+1]-psi[ic,i-1])/(theta[i+1]-theta[i-1]) + # Theta vs dpsi_dth (also checks deriv versus explicit) + fig1, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): ax1.plot(theta,dpsidth[0,:],label='func') @@ -270,16 +205,16 @@ def main(argv): # ------------------------------------------------------------------------- # Generic VGs init_wkf_args = [alphas[0],psds[0],th_sats[0],th_ress[0],tort[0]] # alpha, psd, th_sat, th_res - iret = setwkf(ci(1),ci(1),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + iret = setwkf(ci(1),ci(wkf_type[0]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - init_wkf_args = [th_sats[0],p50[0],avuln[0]] - iret = setwkf(ci(2),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + init_wkf_args = [p50[1],avuln[1]] + iret = setwkf(ci(2),ci(wkf_type[1]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - init_wkf_args = [th_sats[1],p50[1],avuln[1]] - iret = setwkf(ci(3),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + init_wkf_args = [p50[2],avuln[2]] + iret = setwkf(ci(3),ci(wkf_type[2]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - init_wkf_args = [th_sats[2],p50[2],avuln[2]] - iret = setwkf(ci(4),ci(3),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + init_wkf_args = [p50[3],avuln[3]] + iret = setwkf(ci(4),ci(wkf_type[3]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) ftc = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) dftcdpsi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) @@ -296,6 +231,7 @@ def main(argv): cdftcdpsi[ic,i] = (ftc[ic,i+1]-ftc[ic,i-1])/(psi[ic,i+1]-psi[ic,i-1]) + # FTC versus Psi fig2, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): @@ -303,7 +239,7 @@ def main(argv): ax1.set_ylabel('FTC') ax1.set_xlabel('Psi [MPa]') - ax1.set_xlim([-10,3]) + ax1.set_xlim([-10,0]) ax1.legend(loc='upper right') diff --git a/functional_unit_testing/hydro/build_hydro_f90_objects.sh b/functional_unit_testing/hydro/build_hydro_f90_objects.sh index 13bd7d0432..63cb80a7dc 100755 --- a/functional_unit_testing/hydro/build_hydro_f90_objects.sh +++ b/functional_unit_testing/hydro/build_hydro_f90_objects.sh @@ -34,24 +34,11 @@ sed -i "/private /i public :: fates_int" f90_src/FatesConstantsMod.F90 sed -i "/$old_fates_r8_str/d" f90_src/FatesConstantsMod.F90 sed -i "/$old_fates_int_str/d" f90_src/FatesConstantsMod.F90 - -# This re-writes the wrapper so that it uses all the correct parameters -# in FatesAllometryMod.F90 -python AutoGenVarCon.py - - -# Procedure for auto-generating AllomUnitWrap -# 1) scan FatesAllometry and create list of EDPftVarcon_inst variables -# 2) scan EDpftVarcon and get the name of the in-file parameter names associated -# with these variables - - - # Build the new file with constants ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o f90_src/FatesConstantsMod.F90 -${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 +#${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/UnitWrapMod.o f90_src/UnitWrapMod.F90 @@ -59,7 +46,6 @@ ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroWTFMod.o ../../biogeop ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/HydroUnitWrapMod.o f90_src/HydroUnitWrapMod.F90 -#${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroUnitFunctionsMod.o ../../biogeophys/FatesHydroUnitFunctionsMod.F90 diff --git a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 index 16d06f8661..735ef82fd0 100644 --- a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -43,7 +43,7 @@ subroutine InitAllocWTFs(n_wrfs,n_wkfs) return end subroutine InitAllocWTFs - + ! ===================================================================================== subroutine SetWRF(index,itype,npvals,pvals) diff --git a/functional_unit_testing/hydro/f90_src/UnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/UnitWrapMod.F90 new file mode 100644 index 0000000000..f12311655a --- /dev/null +++ b/functional_unit_testing/hydro/f90_src/UnitWrapMod.F90 @@ -0,0 +1,49 @@ + +! ======================================================================================= +! +! This file is an alternative to key files in the fates +! filesystem. Noteably, we replace fates_r8 and fates_in +! with types that work with "ctypes". This is +! a key step in working with python +! +! We also wrap FatesGlobals to reduce the dependancy +! cascade that it pulls in from shr_log_mod. +! +! ======================================================================================= + +module shr_log_mod + + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + + contains + + function shr_log_errMsg(source, line) result(ans) + character(kind=c_char,len=*), intent(in) :: source + integer(c_int), intent(in) :: line + character(kind=c_char,len=128) :: ans + + ans = "source: " // trim(source) // " line: " + end function shr_log_errMsg + +end module shr_log_mod + + +module FatesGlobals + + contains + + integer function fates_log() + fates_log = -1 + end function fates_log + + subroutine fates_endrun(msg) + + implicit none + character(len=*), intent(in) :: msg ! string to be printed + + stop + + end subroutine fates_endrun + +end module FatesGlobals From bb0e615d156d8fdd569140a932b93ef912e2696d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 10 Feb 2020 11:39:26 -0800 Subject: [PATCH 059/114] hydro, more diagnostics and debugging refactors --- biogeophys/FatesHydroWTFMod.F90 | 101 ++-- biogeophys/FatesPlantHydraulicsMod.F90 | 240 ++++++--- .../hydro/HydroUTestDriver.py | 510 +++--------------- main/FatesHydraulicsMemMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 2 - 5 files changed, 294 insertions(+), 561 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 4ca838206b..197d0fc93a 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -28,10 +28,10 @@ module FatesHydroWTFMod __FILE__ - real(r8), parameter :: min_ftc = 0.005_r8 + real(r8), parameter :: min_ftc = 0.0005_r8 real(r8), parameter :: min_rwc_interp = 0.02 - real(r8), parameter :: max_rwc_interp = 0.98 + real(r8), parameter :: max_rwc_interp = 0.95 ! Generic class that can be extended to describe ! specific water retention functions @@ -59,7 +59,9 @@ module FatesHydroWTFMod ! we require these holders type, public :: wrf_arr_type - class(wrf_type), pointer :: p + class(wrf_type), pointer :: p + real(r8) :: th_sat + real(r8) :: psi_sat end type wrf_arr_type type, public :: wkf_arr_type @@ -148,13 +150,6 @@ module FatesHydroWTFMod ! Functional definitions follow here ! Start off by writing the base types, which ultimately should never be pointed to. ! ===================================================================================== -! procedure :: th_from_psi => th_from_psi -! procedure :: psi_from_th => psi_from_th -! procedure :: dpsidth_from_th => dpsidth_from_th -! procedure :: set_wrf_param => set_wrf_param -! -! procedure :: set_wkf_param => set_wkf_param - subroutine set_wrf_param_base(this,params_in) class(wrf_type) :: this @@ -231,7 +226,7 @@ subroutine set_wrf_param_vg(this,params_in) this%psd = params_in(2) this%th_sat = params_in(3) this%th_res = params_in(4) - + return end subroutine set_wrf_param_vg @@ -263,16 +258,34 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: satfrac ! Saturated fraction [-] real(r8) :: th ! Volumetric Water Cont [m3/m3] - !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m - ! Saturation fraction - ! + real(r8) :: psi_interp ! psi where we start lin interp + real(r8) :: th_interp ! th where we start lin interp + real(r8) :: dpsidth_interp + real(r8) :: m + + m = 1._r8/this%psd + + ! pressure above which we use a linear function + psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m - satfrac = (1._r8 + (-this%alpha*psi)**this%psd)**(-1._r8+1._r8/this%psd) + ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m -! print*,'satfrac: ',satfrac - ! convert to volumetric water content - th = satfrac*(this%th_sat-this%th_res) + this%th_res + if(psimax_rwc_interp) then + if(satfrac>=max_rwc_interp) then -!! th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res -!! dpsidth_interp = this%dpsidth_from_th(th_interp) -!! psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m -!! psi = psi_interp + dpsidth_interp*(th-th_interp) + th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res + dpsidth_interp = this%dpsidth_from_th(th_interp) + psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m + psi = psi_interp + dpsidth_interp*(th-th_interp) !! elseif(satfracth_interp) then + satfrac = max_rwc_interp + else + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + end if + dsatfrac_dth = 1._r8/(this%th_sat-this%th_res) ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m @@ -498,9 +508,7 @@ function th_from_psi_cch(this,psi) result(th) real(r8) :: th real(r8) :: satfrac - satfrac = (psi/this%psi_sat)**(-1.0_r8/this%beta) - - th = satfrac*this%th_sat + th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) end function th_from_psi_cch @@ -541,10 +549,11 @@ function ftc_from_psi_cch(this,psi) result(ftc) real(r8) :: psi_eff real(r8) :: ftc - ! th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) - ! ftc = ((psi/this%psi_sat)**(-1.0_r8/this%beta))**(2._r8*this%beta+3._r8) - ! - ! Prevent super-saturation from generating unreasonable FTCs + ! ftc = (th/th_sat)**(2*b+3) + ! = (th_sat*(psi/psi_sat)**(-1/b)/th_sat)**(2*b+3) + ! = ((psi/psi_sat)**(-1/b))**(2*b+3) + ! = (psi/psi_sat)**(-2-3/b) + psi_eff = min(psi,this%psi_sat) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 7f5fbc2eeb..46d73f133a 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -165,7 +165,7 @@ module FatesPlantHydraulicsMod integer, parameter :: plant_wrf_type = van_genuchten_type integer, parameter :: plant_wkf_type = tfs_type ! integer, parameter :: soil_wrf_type = campbell_type - integer, parameter :: soil_wrf_type = van_genuchten_type + integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type @@ -179,10 +179,6 @@ module FatesPlantHydraulicsMod class(wkf_arr_type), pointer :: wkf_plant(:,:) - - - - real(r8), parameter :: alpha_vg = 0.001_r8 real(r8), parameter :: th_sat_vg = 0.65_r8 real(r8), parameter :: th_res_vg = 0.15_r8 @@ -339,12 +335,14 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- + + select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevsoi_hyd allocate(wrf_vg) sites(s)%si_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, bc_in(s)%watsat_sisl(j), th_res_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevsoi_hyd @@ -404,7 +402,7 @@ end subroutine RestartHydrStates ! ==================================================================================== - subroutine initTreeHydStates(site_p, cc_p, bc_in) + subroutine initTreeHydStates(site, cohort, bc_in) ! REQUIRED INPUTS: ! @@ -417,94 +415,129 @@ subroutine initTreeHydStates(site_p, cc_p, bc_in) ! !USES: ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: site_p ! current cohort pointer - type(ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer - type(bc_in_type) , intent(in) :: bc_in + type(ed_site_type), intent(inout), target :: site ! current site pointer + type(ed_cohort_type), intent(inout), target :: cohort ! current cohort pointer + type(bc_in_type) , intent(in) :: bc_in ! input boundary condition ! ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: cCohort - type(ed_site_type), pointer :: csite - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: site_hydr + type(ed_cohort_hydr_type), pointer :: cohort_hydr integer :: j,k,ft ! indices + real(r8) :: psi_rhiz1 real(r8) :: dz real(r8) :: smp - real(r8) :: psi_rev - - cCohort => cc_p - ccohort_hydr => cCohort%co_hydr - csite => site_p - ft = cCohort%pft + real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots - !convert soil water contents to water potential in each soil layer and - !assign it to the absorbing root (assume absorbing root water potential - !in equlibrium w/ surrounding soil) - do j=1, site_p%si_hydr%nlevsoi_hyd - - !call swcVG_psi_from_th(waterstate_inst%h2osoi_liqvol_shell(c,j,1), & - ! watsat(c,j), watres(c,j), alpha_VG(c,j), n_VG(c,j), m_VG(c,j), l_VG(c,j), & - ! smp) - !ccohort_hydr%psi_aroot(j) = smp - ccohort_hydr%psi_aroot(j) = -0.2_r8 !do not assume the equilibrium between soil and root + real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa + real(r8), parameter :: dh_dz = 0.2_r8 ! amount to decrease downstream + ! compartment total potentials [MPa/meter] + + ! In init mode = 1, set absorbing roots to -0.2 MPa + ! = 2, use soil as starting point, match total potentials + ! and then reduce plant compartment total potential by 1KPa + ! for transporting root node, match the lowest total potential + ! in absorbing roots + integer, parameter :: init_mode = 2 + + + site_hydr => site%si_hydr + cohort_hydr => cohort%co_hydr + ft = cohort%pft - ccohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_aroot(j)) + ! Set abosrbing root - psi_rev = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + if(init_mode == 2) then + + h_aroot_mean = 0._r8 - ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) + do j=1, site_hydr%nlevsoi_hyd + + ! Match the potential of the absorbing root to the inner rhizosphere shell + cohort_hydr%psi_aroot(j) = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) - end do + ! Calculate the mean total potential (include height) of absorbing roots + h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-bc_in%z_sisl(j)) + + cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + end do + + else + + do j=1, site_hydr%nlevsoi_hyd + cohort_hydr%psi_aroot(j) = psi_aroot_init + ! Calculate the mean total potential (include height) of absorbing roots + h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-bc_in%z_sisl(j)) + cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + end do + end if + + h_aroot_mean = h_aroot_mean/real(site_hydr%nlevsoi_hyd,r8) - !initialize plant water potentials at hydrostatic equilibrium (dh/dz = 0) - !the assumption is made here that initial conditions for soil water will - !be in (or at least close to) hydrostatic equilibrium as well, so that - !it doesn't matter which absorbing root layer the transporting root water - !potential is referenced to. + ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) + ! the assumption is made here that initial conditions for soil water will + ! be in (or at least close to) hydrostatic equilibrium as well, so that + ! it doesn't matter which absorbing root layer the transporting root water - !(positive means troot is higher than aroot) - ! h_troot = h_aroot - ! psi_troot + z_troot = psi_aroot + z_aroot - ! psi_troot = psi_aroot - (z_troot - z_aroot) - dz = ccohort_hydr%z_node_troot - (-bc_in%z_sisl(1)) + ! Set the transporting root to be in equilibrium with mean potential + ! of the absorbing roots, minus any gradient we add - ccohort_hydr%psi_troot = ccohort_hydr%psi_aroot(1) - mpa_per_pa*denh2o*grav_earth*dz - if (ccohort_hydr%psi_troot>0.0_r8) ccohort_hydr%psi_troot = -0.01_r8 + cohort_hydr%psi_troot = h_aroot_mean - & + mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz - ccohort_hydr%th_troot = wrf_plant(troot_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_troot) + cohort_hydr%th_troot = wrf_plant(troot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_troot) - ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + ! working our way up a tree, assigning water potentials that are in + ! hydrostatic equilibrium (minus dh_dz offset) with the water potential immediately below + dz = cohort_hydr%z_node_ag(n_hypool_ag) - cohort_hydr%z_node_troot + + cohort_hydr%psi_ag(n_hypool_ag) = cohort_hydr%psi_troot - & + mpa_per_pa*denh2o*grav_earth*dz - dh_dz - !working our way up a tree, assigning water potentials that are in - !hydrostatic equilibrium with the water potential immediately below - dz = ccohort_hydr%z_node_ag(n_hypool_ag) - ccohort_hydr%z_node_troot - ccohort_hydr%psi_ag(n_hypool_ag) = ccohort_hydr%psi_troot - mpa_per_pa*denh2o*grav_earth*dz - if (ccohort_hydr%psi_ag(n_hypool_ag)>0.0_r8) ccohort_hydr%psi_ag(n_hypool_ag) = -0.01_r8 - ccohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_ag(n_hypool_ag)) - ccohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(n_hypool_ag)) + cohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) + cohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) + do k=n_hypool_ag-1, 1, -1 - dz = ccohort_hydr%z_node_ag(k) - ccohort_hydr%z_node_ag(k+1) - ccohort_hydr%psi_ag(k) = ccohort_hydr%psi_ag(k+1) - mpa_per_pa*denh2o*grav_earth*dz - if(ccohort_hydr%psi_ag(k)>0.0_r8) ccohort_hydr%psi_ag(k)= -0.01_r8 - ccohort_hydr%th_ag(k) = wrf_plant(stem_p_media,ft)%p%th_from_psi(ccohort_hydr%psi_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + dz = cohort_hydr%z_node_ag(k) - cohort_hydr%z_node_ag(k+1) + cohort_hydr%psi_ag(k) = cohort_hydr%psi_ag(k+1) - & + mpa_per_pa*denh2o*grav_earth*dz - & + dh_dz + + cohort_hydr%th_ag(k) = wrf_plant(site_hydr%pm_node(k),ft)%p%th_from_psi(cohort_hydr%psi_ag(k)) + cohort_hydr%ftc_ag(k) = wkf_plant(site_hydr%pm_node(k),ft)%p%ftc_from_psi(cohort_hydr%psi_ag(k)) end do - ccohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 - ccohort_hydr%errh2o_growturn_troot = 0.0_r8 - ccohort_hydr%errh2o_growturn_aroot = 0.0_r8 - ccohort_hydr%errh2o_pheno_ag(:) = 0.0_r8 - ccohort_hydr%errh2o_pheno_troot = 0.0_r8 - ccohort_hydr%errh2o_pheno_aroot = 0.0_r8 + cohort_hydr%errh2o_growturn_ag(:) = 0.0_r8 + cohort_hydr%errh2o_growturn_troot = 0.0_r8 + cohort_hydr%errh2o_growturn_aroot = 0.0_r8 + cohort_hydr%errh2o_pheno_ag(:) = 0.0_r8 + cohort_hydr%errh2o_pheno_troot = 0.0_r8 + cohort_hydr%errh2o_pheno_aroot = 0.0_r8 !initialize cohort-level btran - ccohort_hydr%btran = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + cohort_hydr%btran = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(1)) + + !flc_gs_from_psi(cohort_hydr%psi_ag(1),cohort%pft) + + ! Check plant pressures, make sure they are not positive + if ( (cohort_hydr%psi_troot>0.0_r8) .or. & + any(cohort_hydr%psi_ag(:)>0._r8) .or. & + any(cohort_hydr%psi_aroot(:)>0._r8) ) then + write(fates_log(),*) 'Initialized plant compartments with positive pressure?' + write(fates_log(),*) 'psi troot: ',cohort_hydr%psi_troot + write(fates_log(),*) 'psi ag(:): ',cohort_hydr%psi_ag(:) + write(fates_log(),*) 'psi_aroot(:): ',cohort_hydr%psi_aroot(:) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - !flc_gs_from_psi(ccohort_hydr%psi_ag(1),ccohort%pft) end subroutine initTreeHydStates @@ -1300,9 +1333,6 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- - print*,bc_in(s)%watsat_sisl(:) - stop - select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevsoi_hyd @@ -2482,10 +2512,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Update total site-level stored plant water [kg/m2] ! (this is not zerod, but incremented) site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV - - - - ! --------------------------------------------------------- @@ -2534,6 +2560,10 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) + print*,'qflx_soil2root_sisl(j):',j,bc_out(s)%qflx_soil2root_sisl(j) + + + ! Save the amount of liquid soil water known to the model after root uptake ! This calculation also assumes that 1mm of water is 1kg site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & @@ -2558,8 +2588,13 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%v_shell(j,i)*AREA_INV*denh2o site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j)-thsat_buff + print*,'runoff: ', (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o end if end do + + + print*,'th: ',site_hydr%h2osoi_liqvol_shell(j,:) enddo @@ -3233,7 +3268,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & print*,"REALLY SMALL ROOTFR?",rootfr_scaler stop end if - else + else rootfr_scaler = 1.0_r8 end if @@ -3264,7 +3299,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) end if - end do ! Outer iteration loop @@ -3275,9 +3309,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & iter = 0 do while( .not.solution_found ) - - - ! Gracefully quit if too many iterations have been used if(iter>max_iter)then call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & @@ -3342,7 +3373,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & end if end if - end do + end do ! Same updates as loop above, but for rhizosphere shells @@ -3355,6 +3386,14 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) end do +! print*,'init' +! print*,'psi:',psi_node(:) +! print*,'ftc:',ftc_node(:) +! print*,'h:',h_node(:) +! print*,'relsat:',th_sat_vg-th_node(1:n_hypool_plant) +! print*,'dpsidth:',dpsi_dtheta_node(:) +! print*,'dftcdth:',dftc_dtheta_node(:) +! stop !-------------------------------------------------------------------------------- ! Part 2. Effective conductances over the path-length and Flux terms @@ -3548,7 +3587,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - if(abs(wb_step_err)>max_wb_step_err)then + if(abs(wb_step_err)>max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then solution_found = .false. error_code = 1 error_arr(:) = 0._r8 @@ -3640,13 +3679,20 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & k_eff(j)*(h_node(j+1)-h_node(j)) + & A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) end do - end if + end if + + print*,'Substep completing' end do ! do istep = 1,nsteps (substep loop) + if(.not.solution_found)then + print*,'FAILING SOLVE' + print*,dth_node(:) + end if + iter=iter+1 - end do + end do ! ----------------------------------------------------------- ! Do a final check on water balance error sumed over sub-steps @@ -3725,12 +3771,19 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + if( any(dth_node(:).ne.dth_node(:)) ) then + print*,"Broken solve" + print*,"dth_node:",dth_node(:) + stop + end if + dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & cohort_hydr%l_aroot_layer(ilayer) * & cohort%n / site_hydr%l_aroot_layer(ilayer) - enddo !soil layer (jj -> ilayer) + enddo !soil layer (jj -> ilayer) end associate return @@ -4937,11 +4990,14 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else print*,'psi:',psi_node(k),k + print*,'residual:',residual(k) psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) endif enddo + + stop endif @@ -5191,6 +5247,7 @@ subroutine InitHydroGlobals() ! Define class(wrf_type_vg), pointer :: wrf_vg class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch class(wkf_type_tfs), pointer :: wkf_tfs integer :: ft ! PFT index @@ -5218,10 +5275,17 @@ subroutine InitHydroGlobals() call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) end do end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger retention curves ' - write(fates_log(),*) 'are not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) + case(campbell_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_cch) + wrf_plant(pm,ft)%p => wrf_cch + call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm),EDPftvarcon_inst%hydr_pinot_node(ft,pm),9._r8]) +! this%th_sat = params_in(1) +! this%psi_sat = params_in(2) +! this%beta = params_in(3) + end do + end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not yet added to plants' call endrun(msg=errMsg(sourcefile, __LINE__)) diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index eaa69b00c8..7fc95cfb44 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -71,7 +71,7 @@ # These parameters are matched with the indices in FATES-HYDRO vg_type = 1 -camp_type = 2 +cch_type = 2 tfs_type = 3 isoil1 = 0 # Top soil layer parameters (@BCI) @@ -92,6 +92,50 @@ # ======================================================================================== +class vg_wrf: + def __init__(self,index,alpha, psd, th_sat, th_res): + self.alpha = alpha + self.psd = psd + self.th_sat = th_sat + self.th_res = th_res + init_wrf_args = [self.alpha, self.psd, self.th_sat, self.th_res] + iret = setwrf(ci(index),ci(vg_type),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + +class cch_wrf: + def __init__(self,index,th_sat,psi_sat,beta): + self.th_sat = th_sat + self.psi_sat = psi_sat + self.beta = beta + init_wrf_args = [self.th_sat,self.psi_sat,self.beta] + iret = setwrf(ci(index),ci(cch_type),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + +class vg_wkf: + def __init__(self,index,alpha, psd, th_sat, th_res, tort): + self.alpha = alpha + self.psd = psd + self.th_sat = th_sat + self.th_res = th_res + self.tort = tort + init_wkf_args = [self.alpha, self.psd,self.th_sat,self.th_res,self.tort] + iret = setwkf(ci(index),ci(vg_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + +class cch_wkf: + def __init__(self,index,th_sat,psi_sat,beta): + self.th_sat = th_sat + self.psi_sat = psi_sat + self.beta = beta + init_wkf_args = [self.th_sat,self.psi_sat,self.beta] + iret = setwkf(ci(index),ci(cch_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + +class tfs_wkf: + def __init__(self,index,p50,avuln): + self.avuln = avuln + self.p50 = p50 + init_wkf_args = [self.p50,self.avuln] + iret = setwkf(ci(index),ci(tfs_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + + def main(argv): # First check to make sure python 2.7 is being used @@ -108,11 +152,11 @@ def main(argv): # Read in the arguments # ======================================================================================= - parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') - parser.add_argument('--cdl-file', dest='cdlfile', type=str, \ - help="Input CDL filename. Required.", required=True) +# parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') +# parser.add_argument('--cdl-file', dest='cdlfile', type=str, \ +# help="Input CDL filename. Required.", required=True) - args = parser.parse_args() +# args = parser.parse_args() # Set number of analysis points @@ -121,41 +165,37 @@ def main(argv): # min_theta = np.full(shape=(2),dtype=np.float64,fill_value=np.nan) - wrf_type = [vg_type, vg_type, vg_type, vg_type] - wkf_type = [vg_type, tfs_type, tfs_type, tfs_type] - th_ress = [0.10, 0.10, 0.20, 0.20] - th_sats = [0.65, 0.65, 0.65, 0.65] - alphas = [1.0, 1.0, 1.0, 1.0] - psds = [2.7, 2.7, 2.7, 2.7] - tort = [0.5, 0.5, 0.5, 0.5] +# wrf_type = [vg_type, vg_type, cch_type, cch_type] +# wkf_type = [vg_type, tfs_type, cch_type, tfs_type] - avuln = [2.0, 2.0, 2.5, 2.5] - p50 = [-1.5, -1.5, -2.25, -2.25] +# th_ress = [0.01, 0.10, -9, -9] +# th_sats = [0.55, 0.55, 0.65, 0.65] +# alphas = [1.0, 1.0, 1.0, 1.0] +# psds = [2.7, 2.7, 2.7, 2.7] +# tort = [0.5, 0.5, 0.5, 0.5] +# beta = [-9, -9, 6, 9] +# avuln = [2.0, 2.0, 2.5, 2.5] +# p50 = [-1.5, -1.5, -2.25, -2.25] - ncomp= 4 - # th_sat at BCI over depth: - #0.56664478523835027 0.54903922349686018 0.52782093380496897 0.50773092378032358 0.49398759255861308 0.49059926489050931 0.47927357530747811 0.47244878323265993 0.47244878323265993 0.44112000000000001 0.44112000000000001 0.44112000000000001 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 0.44363999999999998 + ncomp= 3 + + # Allocate memory to our objective classes iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) print('Allocated') - # Push parameters to those classes - # ------------------------------------------------------------------------- - # Generic VGs - init_wrf_args = [alphas[0],psds[0],th_sats[0],th_ress[0]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(1),ci(wrf_type[0]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) - - init_wrf_args = [alphas[1],psds[1],th_sats[1],th_ress[1]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(2),ci(wrf_type[1]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) - init_wrf_args = [alphas[2],psds[2],th_sats[2],th_ress[2]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(3),ci(wrf_type[2]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) - - init_wrf_args = [alphas[3],psds[3],th_sats[3],th_ress[3]] # alpha, psd, th_sat, th_res - iret = setwrf(ci(4),ci(wrf_type[3]),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + # Define the funcions and their parameters + vg_wrf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1) + vg_wkf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1,tort=0.5) + cch_wrf(2,th_sat=0.55, psi_sat=-1.56e-3, beta=6) + cch_wkf(2,th_sat=0.55, psi_sat=-1.56e-3, beta=6) + cch_wrf(3,th_sat=0.55, psi_sat=-1.56e-3, beta=6) + tfs_wkf(3,p50=-1.5, avuln=2.0) + print('initialized WRF') theta = np.linspace(0.10, 0.7, num=npts) @@ -164,7 +204,6 @@ def main(argv): cdpsidth = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) for ic in range(ncomp): - for i,th in enumerate(theta): psi[ic,i] = psi_from_th(ci(ic+1),c8(th)) @@ -173,7 +212,7 @@ def main(argv): fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): - ax1.plot(theta,psi[ic,:]) + ax1.plot(theta,psi[ic,:],label='{}'.format(ic+1)) ax1.set_ylim((-30,5)) ax1.set_ylabel('Matric Potential [MPa]') @@ -198,29 +237,14 @@ def main(argv): ax1.set_xlabel('VWC [m3/m3]') ax1.legend(loc='upper right') - - - # Push parameters to WKF classes # ------------------------------------------------------------------------- # Generic VGs - init_wkf_args = [alphas[0],psds[0],th_sats[0],th_ress[0],tort[0]] # alpha, psd, th_sat, th_res - iret = setwkf(ci(1),ci(wkf_type[0]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - - init_wkf_args = [p50[1],avuln[1]] - iret = setwkf(ci(2),ci(wkf_type[1]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - - init_wkf_args = [p50[2],avuln[2]] - iret = setwkf(ci(3),ci(wkf_type[2]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - - init_wkf_args = [p50[3],avuln[3]] - iret = setwkf(ci(4),ci(wkf_type[3]),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) ftc = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) dftcdpsi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) cdftcdpsi = np.full(shape=(ncomp,len(theta)),dtype=np.float64,fill_value=np.nan) - for ic in range(ncomp): for i in range(0,len(theta)): ftc[ic,i] = ftc_from_psi(ci(ic+1),c8(psi[ic,i])) @@ -239,398 +263,36 @@ def main(argv): ax1.set_ylabel('FTC') ax1.set_xlabel('Psi [MPa]') - ax1.set_xlim([-10,0]) + ax1.set_xlim([-5,0]) ax1.legend(loc='upper right') + # FTC versus theta + + fig4, ax1 = plt.subplots(1,1,figsize=(9,6)) + for ic in range(ncomp): + ax1.plot(theta,ftc[ic,:],label='{}'.format(ic+1)) + + ax1.set_ylabel('FTC') + ax1.set_xlabel('Theta [m3/m3]') + ax1.legend(loc='lower right') + + # dFTC/dPSI fig3,ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): - ax1.plot(psi[ic,:],abs(dftcdpsi[ic,:]-cdftcdpsi[ic,:])/abs(cdftcdpsi[ic,:]),label='{}'.format(ic)) -# ax1.plot(psi[ic,:],cdftcdpsi[ic,:],label='check') +# ax1.plot(psi[ic,:],abs(dftcdpsi[ic,:]-cdftcdpsi[ic,:])/abs(cdftcdpsi[ic,:]),label='{}'.format(ic)) + ax1.plot(psi[ic,:],cdftcdpsi[ic,:],label='check') ax1.set_ylabel('dFTC/dPSI') ax1.set_xlabel('Psi [MPa]') - ax1.set_xlim([-30,3]) +# ax1.set_xlim([-30,3]) # ax1.set_ylim([0,10]) ax1.legend(loc='upper right') plt.show() - code.interact(local=dict(globals(), **locals())) - - - - - - - - exit(0) - - - - - # Test 1 For a set of thetas, calculate psi for each pm. - # =================================================================================== - - pft1 = 1 - pft2 = 2 - - - - if(unconstrained): - min_leaf_theta = 0.01 - max_leaf_theta = 0.99 - min_stem_theta = 0.01 - max_stem_theta = 0.99 - min_troot_theta = 0.01 - max_troot_theta = 0.99 - min_aroot_theta = 0.01 - max_aroot_theta = 0.99 - min_leaf_theta2 = 0.01 - min_stem_theta2 = 0.01 - min_troot_theta2 = 0.01 - min_aroot_theta2 = 0.01 - min_rhiz_theta = 0.01 - max_rhiz_theta = 0.99 - else: - min_leaf_theta = pftparms['hydr_resid_node'].data[pm_leaf-1,pft1-1] - max_leaf_theta = pftparms['hydr_thetas_node'].data[pm_leaf-1,pft1-1] - min_stem_theta = pftparms['hydr_resid_node'].data[pm_stem-1,pft1-1] - max_stem_theta = pftparms['hydr_thetas_node'].data[pm_stem-1,pft1-1] - min_troot_theta = pftparms['hydr_resid_node'].data[pm_troot-1,pft1-1] - max_troot_theta = pftparms['hydr_thetas_node'].data[pm_troot-1,pft1-1] - min_aroot_theta = pftparms['hydr_resid_node'].data[pm_aroot-1,pft1-1] - max_aroot_theta = pftparms['hydr_thetas_node'].data[pm_aroot-1,pft1-1] - min_leaf_theta2 = pftparms['hydr_resid_node'].data[pm_leaf-1,pft2-1] - min_stem_theta2 = pftparms['hydr_resid_node'].data[pm_stem-1,pft2-1] - min_troot_theta2 = pftparms['hydr_resid_node'].data[pm_troot-1,pft2-1] - min_aroot_theta2 = pftparms['hydr_resid_node'].data[pm_aroot-1,pft2-1] - min_rhiz_theta = 0.01 - max_rhiz_theta = watsat[isoil1] - - # Rhizosphere - # ----------------------------------------------------------------------------------- - - rhiz_theta = np.linspace(min_rhiz_theta,max_rhiz_theta, num=npts) - rhiz_psi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_psi2 = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dpsidth = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dpsidthc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_flc = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dflcdpsi = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - rhiz_dflcdpsic = np.full(shape=np.shape(rhiz_theta),dtype=np.float64,fill_value=np.nan) - - - - # Initialize Theta - leaf_theta = np.linspace(min_leaf_theta,max_leaf_theta, num=npts) - stem_theta = np.linspace(min_stem_theta,max_stem_theta, num=npts) - troot_theta = np.linspace(min_troot_theta,max_troot_theta, num=npts) - aroot_theta = np.linspace(min_aroot_theta,max_aroot_theta, num=npts) - leaf_theta2 = np.linspace(min_leaf_theta2,max_leaf_theta, num=npts) - - # Initialize PSI - leaf_psi = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - leaf_psi2 = np.full(shape=np.shape(leaf_theta2),dtype=np.float64,fill_value=np.nan) - stem_psi = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - troot_psi = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - aroot_psi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - - # Initialize dPSI/dtheta derivative and discrete check - leaf_dpsidth = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - leaf_dpsidthc = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - stem_dpsidth = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - stem_dpsidthc = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - troot_dpsidth = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - troot_dpsidthc = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - aroot_dpsidth = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - aroot_dpsidthc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - - - # Initialize the FLC and its derivative - leaf_flc = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - leaf_dflcdpsi = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - leaf_dflcdpsic = np.full(shape=np.shape(leaf_theta),dtype=np.float64,fill_value=np.nan) - - stem_flc = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - stem_dflcdpsi = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - stem_dflcdpsic = np.full(shape=np.shape(stem_theta),dtype=np.float64,fill_value=np.nan) - - troot_flc = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - troot_dflcdpsi = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - troot_dflcdpsic = np.full(shape=np.shape(troot_theta),dtype=np.float64,fill_value=np.nan) - - aroot_flc = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - aroot_dflcdpsi = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - aroot_dflcdpsic = np.full(shape=np.shape(aroot_theta),dtype=np.float64,fill_value=np.nan) - - - - mpl.rcParams.update({'font.size': 15}) - - - # Initialize the return variable - cpsi = c_double(0) - - - # Find PSI for each theta - for i,th in enumerate(leaf_theta): - leaf_psi[i] = psi_from_th(ci(pft1), ci(pm_leaf), c8(th)) - - for i,th in enumerate(leaf_theta2): - leaf_psi2[i] = psi_from_th(ci(pft2),ci(pm_leaf),c8(th)) - - for i,th in enumerate(stem_theta): - stem_psi[i] = psi_from_th(ci(pft1), ci(pm_stem), c8(th)) - - for i,th in enumerate(troot_theta): - troot_psi[i] = psi_from_th(ci(pft1), ci(pm_troot), c8(th)) - - for i,th in enumerate(aroot_theta): - aroot_psi[i] = psi_from_th(ci(pft1), ci(pm_aroot), c8(th)) - - for i,th in enumerate(rhiz_theta): - rhiz_psi[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), \ - c8(watsat[0]), c8(sucsat[0]), c8(bsw[0])) - rhiz_psi2[i] = psi_from_th(ci(pft1), ci(pm_rhiz), c8(th), \ - c8(watsat[1]), c8(sucsat[1]), c8(bsw[1])) - - - fig0, (ax1,ax2) = plt.subplots(1,2,figsize=(9,6)) - ax1.plot(leaf_theta,leaf_psi,label='Leaf') - ax1.plot(stem_theta,stem_psi,label='Stem') - ax1.plot(troot_theta,troot_psi,label='Troot') - ax1.plot(aroot_theta,aroot_psi,label='Aroot') - ax1.plot(rhiz_theta,rhiz_psi,label='Rhiz') - ax1.grid(True) - ax1.set_ylabel('Psi') - ax1.set_xlim((0,1)) - ax1.set_ylim((-20,10)) - ax1.set_xlabel('Theta') - ax1.set_title('PFT: {}'.format(pft1)) - ax1.legend(loc='lower right') - ax2.plot(leaf_theta,semilogneg(leaf_psi),label='Leaf') - ax2.plot(stem_theta,semilogneg(stem_psi),label='Stem') - ax2.plot(troot_theta,semilogneg(troot_psi),label='Troot') - ax2.plot(aroot_theta,semilogneg(aroot_psi),label='Aroot') - ax2.plot(rhiz_theta,semilogneg(rhiz_psi),label='Rhiz') - ax2.grid(True) - ax2.set_ylabel('log(Psi)') - ax2.set_xlim((0,1)) - ax2.set_xlabel('Theta') - - - plt.tight_layout() - - - # Derivative Check on PSI - # ----------------------------------------------------------------------------------- - for i in range(1,len(leaf_theta)-1): - leaf_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_leaf), c8(leaf_theta[i])) - leaf_dpsidthc[i] = (leaf_psi[i+1]-leaf_psi[i-1])/(leaf_theta[i+1]-leaf_theta[i-1]) - - for i in range(1,len(stem_theta)-1): - stem_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_stem), c8(stem_theta[i])) - stem_dpsidthc[i] = (stem_psi[i+1]-stem_psi[i-1])/(stem_theta[i+1]-stem_theta[i-1]) - - for i in range(1,len(troot_theta)-1): - troot_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_troot), c8(troot_theta[i])) - troot_dpsidthc[i] = (troot_psi[i+1]-troot_psi[i-1])/(troot_theta[i+1]-troot_theta[i-1]) - - for i in range(1,len(aroot_theta)-1): - aroot_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_aroot), c8(aroot_theta[i])) - aroot_dpsidthc[i] = (aroot_psi[i+1]-aroot_psi[i-1])/(aroot_theta[i+1]-aroot_theta[i-1]) - - for i in range(1,len(rhiz_theta)-1): - rhiz_dpsidth[i] = dpsidth_from_th(ci(pft1), ci(pm_rhiz), \ - c8(rhiz_theta[i]), c8(watsat[0]), \ - c8(sucsat[0]), c8(bsw[0])) - rhiz_dpsidthc[i] = (rhiz_psi[i+1]-rhiz_psi[i-1])/ \ - (rhiz_theta[i+1]-rhiz_theta[i-1]) - - - fig2, ((ax1,ax2),(ax3,ax4),(ax5,ax6)) = plt.subplots(3,2,figsize=(9,11)) - ax1.plot(leaf_theta,leaf_dpsidth,label='function') - ax1.plot(leaf_theta,leaf_dpsidthc,label='discrete') - ax1.set_xlim((0,1)) - ax1.legend(loc='upper right') - ax1.set_title('Leaf') - ax1.set_ylabel('dpsi/dth') - ax1.grid(True) - ax2.plot(stem_theta,stem_dpsidth) - ax2.plot(stem_theta,stem_dpsidthc) - ax2.set_xlim((0,1)) - ax2.set_title('Stem') - ax2.grid(True) - ax3.plot(troot_theta,troot_dpsidth) - ax3.plot(troot_theta,troot_dpsidthc) - ax3.set_xlim((0,1)) - ax3.set_title('TRoot') - ax3.set_ylabel('dpsi/dth') - ax3.grid(True) - ax4.plot(aroot_theta,aroot_dpsidth) - ax4.plot(aroot_theta,aroot_dpsidthc) - ax4.set_xlim((0,1)) - ax4.set_title('ARoot') - ax4.set_xlabel('theta') - ax4.grid(True) - ax5.plot(rhiz_theta,rhiz_dpsidth) - ax5.plot(rhiz_theta,rhiz_dpsidthc) - ax5.set_xlim((0,1)) - ax5.set_title('Rhiz') - ax5.set_xlabel('theta') - ax5.set_ylabel('dpsi/dth') - ax5.grid(True) - ax6.axis('off') - - plt.tight_layout() - - # Plot out FTC/PSI - # Find PSI for each theta - - - - for i,psi in enumerate(leaf_psi): - leaf_flc[i] = flc_from_psi(ci(pft1), ci(pm_leaf), c8(leaf_theta[i]), c8(psi)) - - for i,psi in enumerate(stem_psi): - stem_flc[i] = flc_from_psi(ci(pft1), ci(pm_stem), c8(stem_theta[i]), c8(psi)) - - for i,psi in enumerate(troot_psi): - troot_flc[i] = flc_from_psi(ci(pft1), ci(pm_troot), c8(troot_theta[i]), c8(psi)) - - - for i,psi in enumerate(aroot_psi): - aroot_flc[i] = flc_from_psi(ci(pft1), ci(pm_aroot), c8(aroot_theta[i]), c8(psi)) - - for i,psi in enumerate(rhiz_psi): - rhiz_flc[i] = flc_from_psi(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]), \ - c8(psi), c8(sucsat[isoil1]), c8(bsw[isoil1])) - - - # back-calculate the derivative - for i in range(1,len(leaf_psi)-1): - leaf_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_leaf), c8(leaf_theta[i]), c8(leaf_psi[i])) - leaf_dflcdpsic[i] = (leaf_flc[i+1]-leaf_flc[i-1]) / \ - (leaf_psi[i+1]-leaf_psi[i-1]) - - for i in range(1,len(stem_psi)-1): - stem_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_stem), c8(stem_theta[i]), c8(stem_psi[i])) - stem_dflcdpsic[i] = (stem_flc[i+1]-stem_flc[i-1]) / \ - (stem_psi[i+1]-stem_psi[i-1]) - - for i in range(1,len(troot_psi)-1): - troot_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_troot), c8(troot_theta[i]), c8(troot_psi[i])) - troot_dflcdpsic[i] = (troot_flc[i+1]-troot_flc[i-1]) / \ - (troot_psi[i+1]-troot_psi[i-1]) - - for i in range(1,len(aroot_psi)-1): - aroot_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1),ci(pm_aroot), c8(aroot_theta[i]), c8(aroot_psi[i])) - aroot_dflcdpsic[i] = (aroot_flc[i+1]-aroot_flc[i-1]) / \ - (aroot_psi[i+1]-aroot_psi[i-1]) - - for i in range(1,len(rhiz_psi)-1): - rhiz_dflcdpsi[i] = dflcdpsi_from_psi(ci(pft1), ci(pm_rhiz), c8(rhiz_theta[i]), \ - c8(rhiz_psi[i]), c8(sucsat[0]), c8(bsw[0])) - rhiz_dflcdpsic[i] = (rhiz_flc[i+1] - rhiz_flc[i-1])/(rhiz_psi[i+1]-rhiz_psi[i-1]) - - - fig3, (ax1,ax2) = plt.subplots(1,2,figsize=(9,6)) - ax1.plot(leaf_psi,leaf_flc,label='Leaf') - ax1.plot(stem_psi,stem_flc,label='Stem') - ax1.plot(troot_psi,troot_flc,label='Troot') - ax1.plot(aroot_psi,aroot_flc,label='Aroot') - ax1.plot(rhiz_psi,rhiz_flc,label='Rhiz') - ax1.grid(True) - ax1.set_ylabel('FTC [-]') - ax1.set_xlabel('Psi [MPa]') - ax1.legend(loc='upper left') - ax1.set_title('PFT: {}'.format(pft1)) - ax2.plot(leaf_theta,leaf_flc,label='leaf') - ax2.plot(stem_theta,stem_flc,label='stem') - ax2.plot(troot_theta,troot_flc,label='troot') - ax2.plot(aroot_theta,aroot_flc,label='aroot') - ax2.plot(rhiz_theta,rhiz_flc,label='rhiz') - ax2.grid(True) - ax2.set_ylabel('FTC [-]') - ax2.set_xlabel('Theta [m3/m3]') - plt.tight_layout() - - fig4, ((ax1,ax2),(ax3,ax4),(ax5,ax6)) = plt.subplots(3,2,figsize=(9,11)) - ax1.plot(leaf_psi,leaf_dflcdpsi,label='function') - ax1.plot(leaf_psi,leaf_dflcdpsic,label='discrete') - ax1.legend(loc='upper left') - ax1.set_ylabel('dFLC/dPsi') - ax1.set_title('Leaf') - ax1.grid(True) - ax2.plot(stem_psi,stem_dflcdpsi) - ax2.plot(stem_psi,stem_dflcdpsic) - ax2.set_title('Stem') - ax2.grid(True) - ax3.plot(leaf_psi,leaf_dflcdpsi) - ax3.plot(leaf_psi,leaf_dflcdpsic) - ax3.set_title('TRoot') - ax3.set_ylabel('dFLC/dPsi') - ax3.grid(True) - ax4.plot(leaf_psi,leaf_dflcdpsi) - ax4.plot(leaf_psi,leaf_dflcdpsic) - ax4.set_title('ARoot') - ax4.set_xlabel('Psi') - ax4.grid(True) - ax5.plot(rhiz_psi,semilogneg(rhiz_dflcdpsi)) - ax5.plot(rhiz_psi,semilogneg(rhiz_dflcdpsic)) - ax5.set_title('Rhiz') - ax5.set_xlabel('Psi') - ax5.set_ylabel('log(dFLC/dPsi)') - ax5.grid(True) - ax6.axis('off') - plt.tight_layout() - - - fig44, ax1 = plt.subplots(1,figsize=(7,7)) - ax1.plot(leaf_theta,leaf_dflcdpsi*leaf_dpsidth,label='leaf') - ax1.plot(stem_theta,stem_dflcdpsi*stem_dpsidth,label='stem') - ax1.plot(troot_theta,troot_dflcdpsi*troot_dpsidth,label='troot') - ax1.plot(aroot_theta,aroot_dflcdpsi*aroot_dpsidth,label='aroot') - ax1.plot(rhiz_theta,rhiz_dflcdpsi*rhiz_dpsidth,label='rhiz') - ax1.legend(loc='upper left') - ax1.set_ylabel('dFLC/dtheta') - ax1.set_xlabel('theta') - ax1.grid(True) - plt.tight_layout() - - - - fig5, (ax1,ax2) = plt.subplots(2) - ax1.plot(rhiz_theta,rhiz_psi,label='Sat={}, PSIsat={}, B={}'.format(watsat[0],-sucsat[0]*9.8*1.e-9*1000.0 ,bsw[0])) - ax1.plot(rhiz_theta,rhiz_psi2,label='Sat={}, PSIsat={}, B={}'.format(watsat[1],-sucsat[1]*9.8*1.e-9*1000.0 ,bsw[1])) - ax1.grid(True) - ax1.set_ylabel('Psi [MPa]') - ax1.set_xlim((0,1)) - ax1.set_xlabel('Theta [m3/m3]') - ax1.set_title('Rhizosphere') - ax1.legend(loc='lower right') - plt.tight_layout() - - ax2.plot(leaf_theta,leaf_psi,label='Leaf') - ax2.plot(stem_theta,stem_psi,label='Stem') - ax2.plot(troot_theta,troot_psi,label='Troot') - ax2.plot(aroot_theta,aroot_psi,label='Aroot') - ax2.grid(True) - ax2.set_ylabel('Psi [MPa]') - ax2.set_xlim((0,1)) - ax2.set_xlabel('Theta [m3/m3]') - ax2.set_title('PFT: {}'.format(pft1)) - ax2.legend(loc='lower right') - plt.tight_layout() - - - - - - plt.show() # code.interact(local=dict(globals(), **locals())) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index ef855fb698..658fe2ef0c 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .true. + logical, parameter, public :: use_2d_hydrosolve = .false. ! Number of soil layers for indexing cohort fine root quanitities diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b7a1b21167..01455b8ed0 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -982,8 +982,6 @@ subroutine zero_bcs(this,s) this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 this%bc_out(s)%qflx_ro_si = 0.0_r8 - print*,"ZEROING BCOUT" - return end subroutine zero_bcs From d0dcb317a785f113c9bf196e6d783b25dbffbc0c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 10 Feb 2020 13:46:32 -0800 Subject: [PATCH 060/114] Hydro: partial re-addition of TFS WRFs --- biogeophys/FatesHydroWTFMod.F90 | 690 +++++++++++++++++++++++++++++++- 1 file changed, 688 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 197d0fc93a..27d4f670dd 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -128,9 +128,25 @@ module FatesHydroWTFMod end type wkf_type_cch ! ===================================================================================== - ! Plant-only fractional loss of conductivity from Chrisoffersen et al. (tfs model) + ! TFS functions ! ===================================================================================== + ! Water Retention Function from TFS + type, public, extends(wrf_type) :: wrf_type_tfs + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: th_res ! Residual volumentric water content [m3/m3] + real(r8) :: pinot ! osmotic potential at full turger [MPa] + real(r8) :: epsil ! bulk elastic modulus [MPa] + + real(r8), parameter :: beta2 = 0.99_r8 ! Smoothing factor + + contains + procedure :: th_from_psi => th_from_psi_tfs + procedure :: psi_from_th => psi_from_th_tfs + procedure :: dpsidth_from_th => dpsidth_from_th_tfs + procedure :: set_wrf_param => set_wrf_param_tfs + end type wrf_type_tfs + ! Water Conductivity Function type, public, extends(wkf_type) :: wkf_type_tfs real(r8) :: p50 ! matric potential at 50% conductivity loss [Mpa] @@ -586,7 +602,7 @@ end function dftcdpsi_from_psi_cch ! ===================================================================================== - ! Fractional loss of conductivity via TFS style functions + ! TFS style functions ! ===================================================================================== subroutine set_wkf_param_tfs(this,params_in) @@ -600,6 +616,122 @@ subroutine set_wkf_param_tfs(this,params_in) return end subroutine set_wkf_param_tfs + subroutine set_wrf_param_tfs(this,params_in) + + class(wrf_type_tfs) :: this + real(r8), intent(in) :: params_in(:) + + this%th_sat = params_in(1) + this%th_res = params_in(2) + this%pinot = params_in(3) + this%epsil = params_in(4) + + return + end subroutine set_wrf_param_tfs + + ! ===================================================================================== + + function th_from_psi_tfs(this,psi) result(th) + + class(wrf_type_tfs) :: this + real(r8), intent(in) :: psi + real(r8) :: th + + + + end function th_from_psi_tfs + + ! ===================================================================================== + + function psi_from_th_tfs(this,th) result(psi) + + class(wrf_type_tfs) :: this + real(r8),intent(in) :: th + real(r8) :: psi + + x = th_node*cap_corr(pm) + ! + call bq2(x, y_bq2) + call cq2(x, y_cq2) + + psi = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2._r8*this%beta2) + + + return + end function psi_from_th_tfs + + ! expanded form of psi from th tfs + + function psi_from_th_tfs(this,th) result(psi) + + class(wrf_type_tfs) :: this + real(r8),intent(in) :: th + real(r8) :: psi + + ! locals + real(r8) :: th_corr ! corrected vol wc [m3/m3] + real(r8) :: psi_elastic ! press from elastic + real(r8) :: psi_capillary ! press from capillary + real(r8) :: psi_capelast ! press from smoothed capillary/elastic + real(r8) :: psi_cavitation ! press from cavitation + real(r8) :: b,c ! quadratic smoothing terms + + th_corr = th * this%cap_corr + + ! Perform two rounds of quadratic smoothing, 1st smooth + ! the elastic and capilary, and then smooth their + ! combined with the caviation + + call elasticPV(th_corr, psi_elastic) + + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves + + psi_capelast = psi_elastic + + else if(pm <= 4) then ! sapwood has a capillary region + + call capillaryPV(th_corr, psi_capillary) + + b = -1._r8*(psi_capillary + psi_elastic) + c = psi_capillary*psi_elastic + psi_cap_elas = (-b - sqrt(b*b - 4._r8*this%beta*c))/(2._r8*this%beta) + + else + write(fates_log(),*) 'TFS WRF was called for an inelligable porous media' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if !porous media + + ! Now lets smooth the result of capilary elastic with cavitation + + ! call cavitationPV(th_corr, psi_cavitation) + ! this is caviation PV: + call solutepsi(th_corr,this%rwcft,this%th_sat,this%th_res,this%pinot,psi_cavitation) + + b = -1._r8*(psi_cap_elas + psi_cavitation) + c = psi_cap_elas*psi_cavitation + + psi = (-b + sqrt(b*b - 4._r8*this%beta*c))/(2._r8*this%beta) + + + return + end function psi_from_th_tfs + + + + + ! ===================================================================================== + + function dpsidth_from_th_tfs(this,th) result(dpsidth) + + class(wrf_type_tfs) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + + + + end function dpsidth_from_th_tfs + ! ===================================================================================== function ftc_from_psi_tfs(this,psi) result(ftc) @@ -644,6 +776,560 @@ function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) end function dftcdpsi_from_psi_tfs + ! ===================================================================================== + ! The following routines are for calculating water retention functions + ! and their derivatives in the TFS model + ! ===================================================================================== + + subroutine bq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + y = -1._r8*(y_tq1 + y_cavitation) + + end subroutine bq2 + + !-------------------------------------------------------------------------------! + subroutine dbq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() + real(r8) :: dcavdth ! returned derivative from dcavitationdth() + !---------------------------------------------------------------------- + + call dtq1dth(ft, pm, x, dydth_tq1) + call dcavitationPVdth(ft, pm, x, dcavdth) + y = -1._r8*(dydth_tq1 + dcavdth) + + end subroutine dbq2dth + + !-------------------------------------------------------------------------------! + subroutine cq2(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + y = y_tq1*y_cavitation + + end subroutine cq2 + + !-------------------------------------------------------------------------------! + subroutine dcq2dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq2() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_tq1 ! returned y (psi) value from tq1() + real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() + real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() + real(r8) :: dcavdth ! returned derivative from dcavitationdth() + !---------------------------------------------------------------------- + + call tq1(ft, pm, x, y_tq1) + call cavitationPV(ft, pm, x, y_cavitation) + call dtq1dth(ft, pm, x, dydth_tq1) + call dcavitationPVdth(ft, pm, x, dcavdth) + y = y_tq1*dcavdth + dydth_tq1*y_cavitation + + end subroutine dcq2dth + + !-------------------------------------------------------------------------------! + subroutine tq1(ft, pm, x, y) + ! + ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or + ! does a smoothing function for capillary-to-elastic region of the plant PV + ! curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq1 ! returned y (psi) value from bq1() + real(r8) :: y_cq1 ! returned y (psi) value from cq1() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + real(r8) :: beta1=0.80_r8 ! smoothing factor + !---------------------------------------------------------------------- + + if(pm == 1) then ! leaves have no capillary region in their PV curves + call elasticPV(ft, pm, x, y_elastic) + y = y_elastic + else if(pm <= 4) then ! sapwood has a capillary region + + ! bq1 + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + + b = -1._r8*(y_capillary + y_elastic) + + ! cq1 +! call capillaryPV(ft, pm, x, y_capillary) +! call elasticPV(ft, pm, x, y_elastic) + c = y_capillary*y_elastic + + +! call bq1(ft, pm, x, y_bq1) +! call cq1(ft, pm, x, y_cq1) + y = (-b - sqrt(b*b - 4._r8*beta1*c))/(2*b) + + end if !porous media + + end subroutine tq1 + + + + + !-------------------------------------------------------------------------------! + subroutine dtq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of tq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_bq1 ! returned y (psi) value from bq1() + real(r8) :: y_cq1 ! returned y (psi) value from cq1() + real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() + real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + real(r8) :: beta1=0.80_r8 ! smoothing factor + !---------------------------------------------------------------------- + + if(pm == 1) then ! leaves have no capillary region in their PV curves + call delasticPVdth(ft, pm, x, delasticdth) + y = delasticdth + else if(pm <= 4) then ! sapwood has a capillary region + call bq1(ft, pm, x, y_bq1) + call cq1(ft, pm, x, y_cq1) + call dbq1dth(ft, pm, x, dydth_bq1) + call dcq1dth(ft, pm, x, dydth_cq1) + y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & + (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) + end if + + end subroutine dtq1dth + + !-------------------------------------------------------------------------------! + + !-------------------------------------------------------------------------------! + subroutine dbq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of bq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + !---------------------------------------------------------------------- + + call dcapillaryPVdth(ft, pm, x, dcapdth) + call delasticPVdth(ft, pm, x, delasticdth) + y = -1._r8*(delasticdth + dcapdth) + + end subroutine dbq1dth + + ! ------------------------------------------------------------------------------ + + subroutine bq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + y = -1._r8*(y_capillary + y_elastic) + + end subroutine bq1 + + !-------------------------------------------------------------------------------! + subroutine cq1(ft, pm, x, y) + ! + ! !DESCRIPTION: component smoothing function for capillary-to-elastic region + ! of the plant PV curve where a discontinuity exists + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + y = y_capillary*y_elastic + + end subroutine cq1 + + !-------------------------------------------------------------------------------! + subroutine dcq1dth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cq1() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() + real(r8) :: y_elastic ! returned y (psi) value from elasticPV() + real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() + real(r8) :: delasticdth ! returned derivative from delasticPVdth() + !---------------------------------------------------------------------- + + call capillaryPV(ft, pm, x, y_capillary) + call elasticPV(ft, pm, x, y_elastic) + call dcapillaryPVdth(ft, pm, x, dcapdth) + call delasticPVdth(ft, pm, x, delasticdth) + y = y_elastic*dcapdth + delasticdth*y_capillary + + end subroutine dcq1dth + + !-------------------------------------------------------------------------------! + subroutine cavitationPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_solute ! returned y (psi) value from solutepsi() + !---------------------------------------------------------------------- + +! call solutepsi(th,rwcft,th_sat,th_res,pinot,psi) +! call solutepsi(ft, pm, x, y_solute) + y = y_solute + + end subroutine cavitationPV + + !-------------------------------------------------------------------------------! + subroutine dcavitationPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dsoldth ! returned derivative from dsolutepsidth() + !---------------------------------------------------------------------- + + call dsolutepsidth(ft, pm, x, dsoldth) + y = dsoldth + + end subroutine dcavitationPVdth + + !-------------------------------------------------------------------------------! + subroutine elasticPV(th,rwcft,th_sat,th_res,pinot,psi) + ! + ! !DESCRIPTION: computes water potential in the elastic region of the plant PV + ! curve as the sum of both solute and elastic components. + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8) , intent(in) :: th + real(r8) , intent(in) :: rwcft + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: th_res + real(r8) , intent(in) :: pinot + real(r8) , intent(out) :: psi ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + real(r8) :: y_solute ! returned y (psi) value from solutepsi() + real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() + !---------------------------------------------------------------------- + + call solutepsi(th,rwcft,th_sat,th_res,pinot,y_solute) + + call pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,y_pressure) + + psi = y_solute + y_pressure + + end subroutine elasticPV + + !-------------------------------------------------------------------------------! + subroutine delasticPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of elasticPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + real(r8) :: dsoldth ! returned derivative from dsolutepsidth() + real(r8) :: dpressdth ! returned derivative from dpressurepsidth() + !---------------------------------------------------------------------- + + call dsolutepsidth(ft, pm, x, dsoldth) + call dpressurepsidth(ft, pm, x, dpressdth) + y = dsoldth + dpressdth + + end subroutine delasticPVdth + + !-------------------------------------------------------------------------------! + subroutine solutepsi(th,rwcft,th_sat,th_res,pinot,psi) + ! + ! !DESCRIPTION: computes solute water potential (negative) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS + + real(r8) , intent(in) :: th ! vol wc [m3 m-3] + real(r8) , intent(in) :: rwcft ! rel wc [-] + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: th_res + real(r8) , intent(in) :: pinot + real(r8) , intent(out) :: psi ! water potential [MPa] + + psi = pinot*th_sat*(rwcft - th_res) / (th - th_sat*th_res) + + end associate + + end subroutine solutepsi + + !-------------------------------------------------------------------------------! + subroutine dsolutepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of solutepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] + thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + ) + + y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & + ((x - thetas(ft,pm)*resid(ft,pm))**2._r8) + + end associate + + end subroutine dsolutepsidth + + !-------------------------------------------------------------------------------! + subroutine pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,psi) + ! + ! !DESCRIPTION: computes pressure water potential (positive) as a function of + ! water content for the plant PV curve. + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8) , intent(in) :: th + real(r8) , intent(in) :: rwcft ! rel wc [-] + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: th_res + real(r8) , intent(in) :: pinot + real(r8) , intent(in) :: epsil + real(r8) , intent(out) :: psi ! water potential [MPa] + + + psi = epsil * (th - th_sat*rwcft) / & + (th_sat*(rwcft-th_res)) - pinot + + end associate + + end subroutine pressurepsi + + !-------------------------------------------------------------------------------! + subroutine dpressurepsidth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] + epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] + ) + + y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) + + end associate + + end subroutine dpressurepsidth + + !-------------------------------------------------------------------------------! + subroutine capillaryPV(ft, pm, x, y) + ! + ! !DESCRIPTION: computes water potential in the capillary region of the plant + ! PV curve (sapwood only) + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! water potential [MPa] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + ) + + y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x + + end associate + + end subroutine capillaryPV + + !-------------------------------------------------------------------------------! + subroutine dcapillaryPVdth(ft, pm, x, y) + ! + ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta + ! + ! !USES: + ! + ! !ARGUMENTS + integer , intent(in) :: ft ! PFT index + integer , intent(in) :: pm ! porous media index + real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + associate(& + thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] + ) + + y = cap_slp(pm)/thetas(ft,pm) + + end associate + + end subroutine dcapillaryPVdth end module FatesHydroWTFMod From 8b7d463e0f55f41da9ffd73ef6f0dd7c49c7070f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 Feb 2020 10:04:28 -0800 Subject: [PATCH 061/114] hydro: cleaning up tfs WRFs, unit testing them --- biogeophys/FatesHydroWTFMod.F90 | 699 +++++------------- biogeophys/FatesPlantHydraulicsMod.F90 | 47 +- .../hydro/HydroUTestDriver.py | 45 +- .../hydro/f90_src/HydroUnitWrapMod.F90 | 8 +- main/FatesHydraulicsMemMod.F90 | 5 + 5 files changed, 265 insertions(+), 539 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 27d4f670dd..5c8a4085f2 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -33,6 +33,13 @@ module FatesHydroWTFMod real(r8), parameter :: min_rwc_interp = 0.02 real(r8), parameter :: max_rwc_interp = 0.95 + real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term + ! in the capillary-elastic region + + real(r8), parameter :: quad_a2 = 0.99_r8 ! Smoothing factor or "A" term in + ! elastic-caviation region + + ! Generic class that can be extended to describe ! specific water retention functions @@ -133,12 +140,18 @@ module FatesHydroWTFMod ! Water Retention Function from TFS type, public, extends(wrf_type) :: wrf_type_tfs + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumentric water content [m3/m3] real(r8) :: pinot ! osmotic potential at full turger [MPa] real(r8) :: epsil ! bulk elastic modulus [MPa] + real(r8) :: rwc_fd ! total RWC @ which elastic drainage begins [-] + real(r8) :: cap_corr ! correction for nonzero psi0x + real(r8) :: cap_int ! intercept of capillary region of curve + real(r8) :: cap_slp ! slope of capillary region of curve + integer :: pmedia ! self describing porous media index + - real(r8), parameter :: beta2 = 0.99_r8 ! Smoothing factor contains procedure :: th_from_psi => th_from_psi_tfs @@ -620,12 +633,17 @@ subroutine set_wrf_param_tfs(this,params_in) class(wrf_type_tfs) :: this real(r8), intent(in) :: params_in(:) - - this%th_sat = params_in(1) - this%th_res = params_in(2) - this%pinot = params_in(3) - this%epsil = params_in(4) + this%th_sat = params_in(1) + this%th_res = params_in(2) + this%pinot = params_in(3) + this%epsil = params_in(4) + this%rwc_fd = params_in(5) + this%cap_corr = params_in(6) + this%cap_int = params_in(7) + this%cap_slp = params_in(8) + this%pmedia = int(params_in(9)) + return end subroutine set_wrf_param_tfs @@ -649,84 +667,143 @@ function psi_from_th_tfs(this,th) result(psi) real(r8),intent(in) :: th real(r8) :: psi - x = th_node*cap_corr(pm) - ! - call bq2(x, y_bq2) - call cq2(x, y_cq2) + ! locals + real(r8) :: th_corr ! corrected vol wc [m3/m3] + real(r8) :: psi_sol + real(r8) :: psi_press + real(r8) :: psi_elastic ! press from elastic + real(r8) :: psi_capillary ! press from capillary + real(r8) :: psi_capelast ! press from smoothed capillary/elastic + real(r8) :: psi_cavitation ! press from cavitation + real(r8) :: b,c ! quadratic smoothing terms + + th_corr = th * this%cap_corr + + ! Perform two rounds of quadratic smoothing, 1st smooth + ! the elastic and capilary, and then smooth their + ! combined with the caviation + + call solutepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,psi_sol) + call pressurepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) + + psi_elastic = psi_sol + psi_press - psi = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2._r8*this%beta2) + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves + + psi_capelast = psi_elastic + + else if(this%pmedia <= 4) then ! sapwood has a capillary region + + call capillarypsi(th_corr,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) + + b = -1._r8*(psi_capillary + psi_elastic) + c = psi_capillary*psi_elastic + psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) + + else + write(fates_log(),*) 'TFS WRF was called for an inelligable porous media' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if !porous media + + ! Now lets smooth the result of capilary elastic with cavitation + + psi_cavitation = psi_sol + b = -1._r8*(psi_capelast + psi_cavitation) + c = psi_capelast*psi_cavitation + + psi = (-b + sqrt(b*b - 4._r8*quad_a2*c))/(2._r8*quad_a2) return end function psi_from_th_tfs - - ! expanded form of psi from th tfs - function psi_from_th_tfs(this,th) result(psi) - - class(wrf_type_tfs) :: this - real(r8),intent(in) :: th - real(r8) :: psi + ! ===================================================================================== + + function dpsidth_from_th_tfs(this,th) result(dpsidth) + + class(wrf_type_tfs) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + ! locals real(r8) :: th_corr ! corrected vol wc [m3/m3] + real(r8) :: psi_sol + real(r8) :: psi_press real(r8) :: psi_elastic ! press from elastic real(r8) :: psi_capillary ! press from capillary real(r8) :: psi_capelast ! press from smoothed capillary/elastic real(r8) :: psi_cavitation ! press from cavitation real(r8) :: b,c ! quadratic smoothing terms - - th_corr = th * this%cap_corr - + real(r8) :: dbdth,dcdth ! derivs of quad smoohting terms + real(r8) :: dsol_dth + real(r8) :: dpress_dth + real(r8) :: delast_dth + real(r8) :: dcap_dth + real(r8) :: dcapelast_dth + real(r8) :: dcav_dth + + + th_corr = th*this%cap_corr + ! Perform two rounds of quadratic smoothing, 1st smooth ! the elastic and capilary, and then smooth their ! combined with the caviation - call elasticPV(th_corr, psi_elastic) + call solutepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,psi_sol) + call pressurepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) + + call dsolutepsidth(th,this%th_sat,this%th_res,this%rwc_fd,this%pinot,dsol_dth) + call dpressurepsidth(this%th_sat,this%th_res,this%rwc_fd,this%epsil,dpress_dth) - if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves + delast_dth = dsol_dth + dpress_dth + psi_elastic = psi_sol + psi_press + + + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves psi_capelast = psi_elastic - - else if(pm <= 4) then ! sapwood has a capillary region + dcapelast_dth = delast_dth - call capillaryPV(th_corr, psi_capillary) + else if(this%pmedia <= 4) then ! sapwood has a capillary region + + call capillarypsi(th,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) b = -1._r8*(psi_capillary + psi_elastic) c = psi_capillary*psi_elastic - psi_cap_elas = (-b - sqrt(b*b - 4._r8*this%beta*c))/(2._r8*this%beta) + psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) + call dcapillarypsidth(this%cap_slp,this%th_sat,dcap_dth) + + dbdth = -1._r8*(delast_dth + dcap_dth) + dcdth = psi_elastic*dcap_dth + delast_dth*psi_capillary + + + dcapelast_dth = 1._r8/(2._r8*quad_a1) * & + (-dbdth - 0.5_r8*((b*b - 4._r8*quad_a1*c)**(-0.5_r8)) * & + (2._r8*b*dbdth - 4._r8*quad_a1*dcdth)) + else - write(fates_log(),*) 'TFS WRF was called for an inelligable porous media' + write(fates_log(),*) 'TFS WRF was called for an ineligible porous media' call endrun(msg=errMsg(sourcefile, __LINE__)) end if !porous media ! Now lets smooth the result of capilary elastic with cavitation - ! call cavitationPV(th_corr, psi_cavitation) - ! this is caviation PV: - call solutepsi(th_corr,this%rwcft,this%th_sat,this%th_res,this%pinot,psi_cavitation) - - b = -1._r8*(psi_cap_elas + psi_cavitation) - c = psi_cap_elas*psi_cavitation - - psi = (-b + sqrt(b*b - 4._r8*this%beta*c))/(2._r8*this%beta) - - - return - end function psi_from_th_tfs + psi_cavitation = psi_sol - + b = -1._r8*(psi_capelast + psi_cavitation) + c = psi_capelast*psi_cavitation - - ! ===================================================================================== - - function dpsidth_from_th_tfs(this,th) result(dpsidth) - - class(wrf_type_tfs) :: this - real(r8),intent(in) :: th - real(r8) :: dpsidth + dcav_dth = dsol_dth + + dbdth = -1._r8*(dcapelast_dth + dcav_dth) + dcdth = psi_capelast*dcav_dth + dcapelast_dth*psi_cavitation + + dpsidth = 1._r8/(2._r8*quad_a2)*(-dbdth + 0.5_r8*((b*b - 4._r8*quad_a2*c)**(-0.5_r8)) * & + (2._r8*b*dbdth - 4._r8*quad_a2*dcdth)) @@ -776,406 +853,9 @@ function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) end function dftcdpsi_from_psi_tfs - ! ===================================================================================== - ! The following routines are for calculating water retention functions - ! and their derivatives in the TFS model - ! ===================================================================================== - - subroutine bq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = -1._r8*(y_tq1 + y_cavitation) - - end subroutine bq2 - - !-------------------------------------------------------------------------------! - subroutine dbq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = -1._r8*(dydth_tq1 + dcavdth) - - end subroutine dbq2dth - - !-------------------------------------------------------------------------------! - subroutine cq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = y_tq1*y_cavitation - - end subroutine cq2 - - !-------------------------------------------------------------------------------! - subroutine dcq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq2() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = y_tq1*dcavdth + dydth_tq1*y_cavitation - - end subroutine dcq2dth - - !-------------------------------------------------------------------------------! - subroutine tq1(ft, pm, x, y) - ! - ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or - ! does a smoothing function for capillary-to-elastic region of the plant PV - ! curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call elasticPV(ft, pm, x, y_elastic) - y = y_elastic - else if(pm <= 4) then ! sapwood has a capillary region - - ! bq1 - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - - b = -1._r8*(y_capillary + y_elastic) - - ! cq1 -! call capillaryPV(ft, pm, x, y_capillary) -! call elasticPV(ft, pm, x, y_elastic) - c = y_capillary*y_elastic - - -! call bq1(ft, pm, x, y_bq1) -! call cq1(ft, pm, x, y_cq1) - y = (-b - sqrt(b*b - 4._r8*beta1*c))/(2*b) - - end if !porous media - - end subroutine tq1 - - - - - - !-------------------------------------------------------------------------------! - subroutine dtq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of tq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() - real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call delasticPVdth(ft, pm, x, delasticdth) - y = delasticdth - else if(pm <= 4) then ! sapwood has a capillary region - call bq1(ft, pm, x, y_bq1) - call cq1(ft, pm, x, y_cq1) - call dbq1dth(ft, pm, x, dydth_bq1) - call dcq1dth(ft, pm, x, dydth_cq1) - y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & - (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) - end if - - end subroutine dtq1dth - - !-------------------------------------------------------------------------------! - - !-------------------------------------------------------------------------------! - subroutine dbq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of bq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = -1._r8*(delasticdth + dcapdth) - - end subroutine dbq1dth - - ! ------------------------------------------------------------------------------ - - subroutine bq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = -1._r8*(y_capillary + y_elastic) - - end subroutine bq1 - - !-------------------------------------------------------------------------------! - subroutine cq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = y_capillary*y_elastic - - end subroutine cq1 - - !-------------------------------------------------------------------------------! - subroutine dcq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = y_elastic*dcapdth + delasticdth*y_capillary - - end subroutine dcq1dth - - !-------------------------------------------------------------------------------! - subroutine cavitationPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - !---------------------------------------------------------------------- - -! call solutepsi(th,rwcft,th_sat,th_res,pinot,psi) -! call solutepsi(ft, pm, x, y_solute) - y = y_solute - - end subroutine cavitationPV - - !-------------------------------------------------------------------------------! - subroutine dcavitationPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - y = dsoldth - - end subroutine dcavitationPVdth - !-------------------------------------------------------------------------------! - subroutine elasticPV(th,rwcft,th_sat,th_res,pinot,psi) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: th - real(r8) , intent(in) :: rwcft - real(r8) , intent(in) :: th_sat - real(r8) , intent(in) :: th_res - real(r8) , intent(in) :: pinot - real(r8) , intent(out) :: psi ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() - !---------------------------------------------------------------------- - call solutepsi(th,rwcft,th_sat,th_res,pinot,y_solute) - - call pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,y_pressure) - - psi = y_solute + y_pressure - - end subroutine elasticPV - - !-------------------------------------------------------------------------------! - subroutine delasticPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of elasticPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - real(r8) :: dpressdth ! returned derivative from dpressurepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - call dpressurepsidth(ft, pm, x, dpressdth) - y = dsoldth + dpressdth - - end subroutine delasticPVdth - - !-------------------------------------------------------------------------------! - subroutine solutepsi(th,rwcft,th_sat,th_res,pinot,psi) + subroutine solutepsi(th,rwc_fd,th_sat,th_res,pinot,psi) ! ! !DESCRIPTION: computes solute water potential (negative) as a function of ! water content for the plant PV curve. @@ -1185,49 +865,42 @@ subroutine solutepsi(th,rwcft,th_sat,th_res,pinot,psi) ! !ARGUMENTS real(r8) , intent(in) :: th ! vol wc [m3 m-3] - real(r8) , intent(in) :: rwcft ! rel wc [-] + real(r8) , intent(in) :: rwc_fd real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res real(r8) , intent(in) :: pinot real(r8) , intent(out) :: psi ! water potential [MPa] - psi = pinot*th_sat*(rwcft - th_res) / (th - th_sat*th_res) - - end associate + psi = pinot*th_sat*(rwc_fd - th_res) / (th - th_sat*th_res) + return end subroutine solutepsi !-------------------------------------------------------------------------------! - subroutine dsolutepsidth(ft, pm, x, y) + + subroutine dsolutepsidth(th,th_sat,th_res,rwc_fd,pinot,dpsi_dth) + ! ! !DESCRIPTION: returns derivative of solutepsi() wrt theta ! ! !USES: ! ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => EDPftvarcon_inst%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => EDPftvarcon_inst%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) + real(r8) , intent(in) :: th + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: th_res + real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: pinot + real(r8) , intent(out) :: dpsi_dth - y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - ((x - thetas(ft,pm)*resid(ft,pm))**2._r8) - - end associate + dpsi_dth = -1._r8*th_sat*pinot*(rwc_fd - th_res )/((th - th_sat*th_res)**2._r8) + return end subroutine dsolutepsidth !-------------------------------------------------------------------------------! - subroutine pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,psi) + + subroutine pressurepsi(th,rwc_fd,th_sat,th_res,pinot,epsil,psi) ! ! !DESCRIPTION: computes pressure water potential (positive) as a function of ! water content for the plant PV curve. @@ -1236,7 +909,7 @@ subroutine pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,psi) ! ! !ARGUMENTS real(r8) , intent(in) :: th - real(r8) , intent(in) :: rwcft ! rel wc [-] + real(r8) , intent(in) :: rwc_fd real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res real(r8) , intent(in) :: pinot @@ -1244,92 +917,68 @@ subroutine pressurepsi(th,rwcft,th_sat,th_res,pinot,epsil,psi) real(r8) , intent(out) :: psi ! water potential [MPa] - psi = epsil * (th - th_sat*rwcft) / & - (th_sat*(rwcft-th_res)) - pinot - - end associate + psi = epsil * (th - th_sat*rwc_fd) / & + (th_sat*(rwc_fd-th_res)) - pinot + return end subroutine pressurepsi !-------------------------------------------------------------------------------! - subroutine dpressurepsidth(ft, pm, x, y) + + subroutine dpressurepsidth(th_sat,th_res,rwc_fd,epsil,dpsi_dth) ! ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta ! ! !USES: ! ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => EDPftvarcon_inst%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - epsil => EDPftvarcon_inst%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] - ) + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: th_res + real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: epsil + real(r8) , intent(out) :: dpsi_dth ! derivative of water potential wrt theta [MPa m3 m-3] - y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) + dpsi_dth = epsil/(th_sat*(rwc_fd - th_res)) - end associate - + return end subroutine dpressurepsidth !-------------------------------------------------------------------------------! - subroutine capillaryPV(ft, pm, x, y) + + subroutine capillarypsi(th,th_sat,cap_int,cap_slp,psi) ! ! !DESCRIPTION: computes water potential in the capillary region of the plant ! PV curve (sapwood only) ! - ! !USES: - ! ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) + + real(r8) , intent(in) :: th ! water content [m3 m-3] + real(r8) , intent(in) :: th_sat + real(r8) , intent(in) :: cap_int + real(r8) , intent(in) :: cap_slp + real(r8) , intent(out) :: psi ! water potential [MPa] - y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x + psi = cap_int + th*cap_slp/th_sat - end associate - - end subroutine capillaryPV + return + end subroutine capillarypsi !-------------------------------------------------------------------------------! - subroutine dcapillaryPVdth(ft, pm, x, y) + + subroutine dcapillarypsidth(cap_slp,th_sat,y) ! ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta ! ! !USES: ! ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] + real(r8) , intent(in) :: cap_slp + real(r8) , intent(in) :: th_sat real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) - - y = cap_slp(pm)/thetas(ft,pm) - - end associate + y = cap_slp/th_sat - end subroutine dcapillaryPVdth + return + end subroutine dcapillarypsidth end module FatesHydroWTFMod diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 46d73f133a..7b1187aa8c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -45,7 +45,9 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_kmax_rsurf1 use EDParamsMod , only : hydr_kmax_rsurf2 - + use EDParamsMod , only : hydr_psi0 + use EDParamsMod , only : hydr_psicap + use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -83,7 +85,8 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: nlevsoi_hyd_max use FatesHydraulicsMemMod, only: cohort_recruit_water_layer use FatesHydraulicsMemMod, only: recruit_water_avail_layer - + use FatesHydraulicsMemMod, only: rwccap, rwcft + use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : store_organ, repro_organ, struct_organ @@ -93,7 +96,7 @@ module FatesPlantHydraulicsMod use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type - use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch + use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrt_type_tfs use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs @@ -5249,6 +5252,7 @@ subroutine InitHydroGlobals() class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch class(wkf_type_tfs), pointer :: wkf_tfs + class(wrf_type_tfs), pointer :: wrf_tfs integer :: ft ! PFT index integer :: pm ! plant media index @@ -5280,13 +5284,40 @@ subroutine InitHydroGlobals() do pm = 1,n_plant_media allocate(wrf_cch) wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm),EDPftvarcon_inst%hydr_pinot_node(ft,pm),9._r8]) -! this%th_sat = params_in(1) -! this%psi_sat = params_in(2) -! this%beta = params_in(3) + call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + 9._r8]) end do end do - case(tfs_type) + case(tfs_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if + + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp]) + end do + end do + + + write(fates_log(),*) 'TFS water retention curves not yet added to plants' call endrun(msg=errMsg(sourcefile, __LINE__)) end select diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 7fc95cfb44..29b822bff0 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -128,6 +128,20 @@ def __init__(self,index,th_sat,psi_sat,beta): iret = setwkf(ci(index),ci(cch_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) +class tfs_wrf: + def __init__(self,index,th_sat,th_res,pinot,epsil,rwc_fd,cap_corr,cap_int,cap_slp,pmedia): + self.th_sat = th_sat + self.th_res = th_res + self.pinot = pinot + self.epsil = epsil + self.rwc_fd = rwc_fd + self.cap_corr = cap_corr + self.cap_int = cap_int + self.cap_slp = cap_slp + self.pmedia = pmedia + init_wrf_args = [self.th_sat,self.th_res,self.pinot,self.epsil,self.rwc_fd,self.cap_corr,self.cap_int,self.cap_slp,self.pmedia] + iret = setwrf(ci(index),ci(tfs_type),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) + class tfs_wkf: def __init__(self,index,p50,avuln): self.avuln = avuln @@ -177,8 +191,25 @@ def main(argv): # avuln = [2.0, 2.0, 2.5, 2.5] # p50 = [-1.5, -1.5, -2.25, -2.25] - ncomp= 3 - + ncomp= 4 + + rwc_fd = [1.0,0.958,0.958,0.958] + rwccap = [1.0,0.947,0.947,0.947] + cap_slp = [] + cap_int = [] + cap_corr= [] + hydr_psi0 = 0.0 + hydr_psicap = -0.6 + + for pm in range(4): + if (pm == 0): + cap_slp.append(0.0) + cap_int.append(0.0) + cap_corr.append(1.0) + else: + cap_slp.append((hydr_psi0 - hydr_psicap )/(1.0 - rwccap[pm])) + cap_int.append(-cap_slp[pm] + hydr_psi0) + cap_corr.append(-cap_int[pm]/cap_slp[pm]) # Allocate memory to our objective classes @@ -194,7 +225,15 @@ def main(argv): cch_wkf(2,th_sat=0.55, psi_sat=-1.56e-3, beta=6) cch_wrf(3,th_sat=0.55, psi_sat=-1.56e-3, beta=6) - tfs_wkf(3,p50=-1.5, avuln=2.0) + tfs_wkf(3,p50=-2.25, avuln=2.0) + + # Leaf + tfs_wrf(4,th_sat=0.65,th_res=0.25,pinot=-1.47, \ + epsil=12,rwc_fd=rwc_fd[0],cap_corr=cap_corr[0], \ + cap_int=cap_int[0],cap_slp=cap_slp[0],pmedia=1) + tfs_wkf(3,p50=-2.25, avuln=2.0) + + print('initialized WRF') diff --git a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 index 735ef82fd0..03e95a6a32 100644 --- a/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -13,7 +13,7 @@ module HydroUnitWrapMod use FatesHydroWTFMod, only : wrf_type,wrf_type_vg,wrf_type_cch use FatesHydroWTFMod, only : wkf_type,wkf_type_vg,wkf_type_cch,wkf_type_tfs - use FatesHydroWTFMod, only : wrf_arr_type,wkf_arr_type + use FatesHydroWTFMod, only : wrf_arr_type,wkf_arr_type,wrf_type_tfs implicit none public @@ -57,6 +57,7 @@ subroutine SetWRF(index,itype,npvals,pvals) class(wrf_type_vg), pointer :: wrf_vg class(wrf_type_cch), pointer :: wrf_cch + class(wrf_type_tfs), pointer :: wrf_tfs print*,"ALLOCATING WRF",index,itype print*,pvals @@ -70,8 +71,9 @@ subroutine SetWRF(index,itype,npvals,pvals) wrfs(index)%p => wrf_cch call wrf_cch%set_wrf_param(pvals) !th_sat,psi_sat,beta else - print*,"UNKNOWN WRF" - stop + allocate(wrf_tfs) + wrfs(index)%p => wrf_tfs + call wrf_tfs%set_wrf_param(pvals) end if return diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 658fe2ef0c..412c3a7262 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -48,6 +48,11 @@ module FatesHydraulicsMemMod integer, parameter, public :: aroot_p_media = 4 integer, parameter, public :: rhiz_p_media = 5 + ! P-V curve: total RWC @ which elastic drainage begins (tfs) [-] + real(r8), parameter, public, dimension(n_porous_media) :: rwcft = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) + ! P-V curve: total RWC @ which capillary reserves exhausted (tfs) + real(r8), parameter, public, dimension(n_porous_media) :: rwccap = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + ! mirror of nlevcan, hard-set for simplicity, remove nlevcan_hyd on a rainy day ! Note (RGK): uscing nclmax causes annoying circular dependency (this needs EDTypes, EDTypes needs this) From 9f2afe78e12cccb824f2e16f70120c2442e69881 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 Feb 2020 15:02:47 -0800 Subject: [PATCH 062/114] hydro: bug fixing refactors --- biogeophys/FatesHydroWTFMod.F90 | 427 ++++++++++++------ biogeophys/FatesPlantHydraulicsMod.F90 | 321 ++++++------- .../hydro/HydroUTestDriver.py | 26 +- main/FatesHydraulicsMemMod.F90 | 6 +- 4 files changed, 480 insertions(+), 300 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 5c8a4085f2..23d1d79a70 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -11,9 +11,9 @@ module FatesHydroWTFMod use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : pi_const use FatesGlobals , only : endrun => fates_endrun - use FatesGlobals , only : fates_log + use FatesGlobals , only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg - + implicit none private @@ -35,11 +35,11 @@ module FatesHydroWTFMod real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region - + real(r8), parameter :: quad_a2 = 0.99_r8 ! Smoothing factor or "A" term in ! elastic-caviation region - + ! Generic class that can be extended to describe ! specific water retention functions @@ -70,7 +70,7 @@ module FatesHydroWTFMod real(r8) :: th_sat real(r8) :: psi_sat end type wrf_arr_type - + type, public :: wkf_arr_type class(wkf_type), pointer :: p end type wkf_arr_type @@ -86,7 +86,7 @@ module FatesHydroWTFMod real(r8) :: psd ! Inverse width of pore size distribution parameter real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] - + contains procedure :: th_from_psi => th_from_psi_vg procedure :: psi_from_th => psi_from_th_vg @@ -116,6 +116,8 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + real(r8) :: psi_max ! psi where rwc = rwc_max_interp, and use linear + real(r8) :: dpsidth_max ! deriv wrt theta for psi_max contains procedure :: th_from_psi => th_from_psi_cch procedure :: psi_from_th => psi_from_th_cch @@ -145,19 +147,23 @@ module FatesHydroWTFMod real(r8) :: th_res ! Residual volumentric water content [m3/m3] real(r8) :: pinot ! osmotic potential at full turger [MPa] real(r8) :: epsil ! bulk elastic modulus [MPa] - real(r8) :: rwc_fd ! total RWC @ which elastic drainage begins [-] + real(r8) :: rwc_fd ! total RWC @ which elastic drainage begins [-] real(r8) :: cap_corr ! correction for nonzero psi0x real(r8) :: cap_int ! intercept of capillary region of curve real(r8) :: cap_slp ! slope of capillary region of curve integer :: pmedia ! self describing porous media index - + real(r8) :: psi_max ! psi matching max_rwc_interp where we start linear interp + real(r8) :: dpsidth_max ! dpsi_dth where we start linear interp + real(r8) :: psi_min ! psi matching min_rwc_interp + real(r8) :: dpsidth_min ! dpsi_dth where we start min interp contains procedure :: th_from_psi => th_from_psi_tfs procedure :: psi_from_th => psi_from_th_tfs procedure :: dpsidth_from_th => dpsidth_from_th_tfs procedure :: set_wrf_param => set_wrf_param_tfs + procedure :: bisect_pv end type wrf_type_tfs ! Water Conductivity Function @@ -165,14 +171,14 @@ module FatesHydroWTFMod real(r8) :: p50 ! matric potential at 50% conductivity loss [Mpa] real(r8) :: avuln ! vulnerability curve parameter real(r8) :: th_sat ! volumetric water content at saturation - + contains procedure :: ftc_from_psi => ftc_from_psi_tfs procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_tfs procedure :: set_wkf_param => set_wkf_param_tfs end type wkf_type_tfs - - + + contains ! ===================================================================================== @@ -247,7 +253,7 @@ end function dftcdpsi_from_psi_base ! ===================================================================================== subroutine set_wrf_param_vg(this,params_in) - + class(wrf_type_vg) :: this real(r8), intent(in) :: params_in(:) @@ -255,14 +261,14 @@ subroutine set_wrf_param_vg(this,params_in) this%psd = params_in(2) this%th_sat = params_in(3) this%th_res = params_in(4) - + return end subroutine set_wrf_param_vg ! ===================================================================================== subroutine set_wkf_param_vg(this,params_in) - + class(wkf_type_vg) :: this real(r8), intent(in) :: params_in(:) @@ -271,17 +277,17 @@ subroutine set_wkf_param_vg(this,params_in) this%th_sat = params_in(3) this%th_res = params_in(4) this%tort = params_in(5) - + return end subroutine set_wkf_param_vg ! ===================================================================================== - + function th_from_psi_vg(this,psi) result(th) - + ! Van Genuchten (1980) calculation of volumetric water content (theta) ! from matric potential. - + class(wrf_type_vg) :: this real(r8), intent(in) :: psi ! Matric potential [MPa] real(r8) :: satfrac ! Saturated fraction [-] @@ -293,18 +299,18 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: m m = 1._r8/this%psd - + ! pressure above which we use a linear function psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m - ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + - if(psi=max_rwc_interp) then th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res @@ -352,18 +358,18 @@ function psi_from_th_vg(this,th) result(psi) psi = psi_interp + dpsidth_interp*(th-th_interp) !! elseif(satfracthis%psi_max) then + ! Linear range for extreme values + th = max_rwc_interp*this%th_sat + (psi-this%psi_max)/this%dpsidth_max + else + th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) + end if + return end function th_from_psi_cch ! ===================================================================================== function psi_from_th_cch(this,th) result(psi) - + class(wrf_type_cch) :: this real(r8),intent(in) :: th real(r8) :: psi + real(r8) :: rwc - psi = this%psi_sat*(th/this%th_sat)**(-this%beta) + rwc = th/this%th_sat + if(rwc>max_rwc_interp) then + psi = this%psi_max + this%dpsidth_max*(th-max_rwc_interp*this%th_sat) + else + psi = this%psi_sat*(th/this%th_sat)**(-this%beta) + end if end function psi_from_th_cch - + ! ===================================================================================== function dpsidth_from_th_cch(this,th) result(dpsidth) @@ -561,12 +583,12 @@ function dpsidth_from_th_cch(this,th) result(dpsidth) real(r8),intent(in) :: th real(r8) :: dpsidth - ! Differentiate: + ! Differentiate: ! psi = this%psi_sat*(th/this%th_sat)**(-this%beta) dpsidth = -this%beta*this%psi_sat/this%th_sat * (th/this%th_sat)**(-this%beta-1._r8) - + end function dpsidth_from_th_cch ! ===================================================================================== @@ -577,23 +599,23 @@ function ftc_from_psi_cch(this,psi) result(ftc) real(r8),intent(in) :: psi real(r8) :: psi_eff real(r8) :: ftc - + ! ftc = (th/th_sat)**(2*b+3) ! = (th_sat*(psi/psi_sat)**(-1/b)/th_sat)**(2*b+3) ! = ((psi/psi_sat)**(-1/b))**(2*b+3) ! = (psi/psi_sat)**(-2-3/b) - + psi_eff = min(psi,this%psi_sat) - + ftc = (psi_eff/this%psi_sat)**(-2._r8-3._r8/this%beta) - + end function ftc_from_psi_cch ! ==================================================================================== function dftcdpsi_from_psi_cch(this,psi) result(dftcdpsi) - + class(wkf_type_cch) :: this real(r8),intent(in) :: psi real(r8) :: dftcdpsi ! change in frac total cond wrt psi @@ -604,7 +626,7 @@ function dftcdpsi_from_psi_cch(this,psi) result(dftcdpsi) ! Note that if we assume a constant, capped FTC=1.0 ! at saturation, then the derivative is zero there if(psithis%psi_max) then + ! Linear range for extreme values + th = this%th_res+max_rwc_interp*(this%th_sat-this%th_res) + & + (psi-this%psi_max)/this%dpsidth_max + + elseif(psi -1.e-8_r8) then + write(fates_log(),*)'bisect_pv returned positive value for water potential?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + return end function th_from_psi_tfs ! ===================================================================================== function psi_from_th_tfs(this,th) result(psi) - + class(wrf_type_tfs) :: this real(r8),intent(in) :: th real(r8) :: psi @@ -676,6 +746,23 @@ function psi_from_th_tfs(this,th) result(psi) real(r8) :: psi_capelast ! press from smoothed capillary/elastic real(r8) :: psi_cavitation ! press from cavitation real(r8) :: b,c ! quadratic smoothing terms + real(r8) :: rwc ! relative water content (between res and sat) + + rwc = (th-this%th_res)/(this%th_sat-this%th_res) + + if(rwc>max_rwc_interp) then + + psi = this%psi_max + this%dpsidth_max * & + (th-(max_rwc_interp*(this%th_sat-this%th_res)+this%th_res)) + + elseif(rwcmax_rwc_interp) then + + dpsidth = this%dpsidth_max + + elseif(rwc 0.0_r8) then + write(fates_log(),*)'Error: psi become positive during pv bisection' + write(fates_log(),*)'psi: ',psi + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + y_lo = this%psi_from_th(lower) + y_hi = this%psi_from_th(upper) + + f_lo = y_lo - psi + f_hi = y_hi - psi + chg = upper - lower + + nitr = 0 + do while(abs(chg) .gt. xtol .and. nitr < 100) + x_new = 0.5_r8*(lower + upper) + y_new = this%psi_from_th(x_new) + f_new = y_new - psi + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower + nitr = nitr + 1 + end do + + if(nitr .eq. 100)then + write(fates_log(),*)'Warning: number of iteraction reaches 100 for bisect_pv' + endif + + th = x_new + + end subroutine bisect_pv + + end module FatesHydroWTFMod diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 7b1187aa8c..30e4353dca 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -96,7 +96,7 @@ module FatesPlantHydraulicsMod use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type - use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrt_type_tfs + use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs @@ -135,6 +135,10 @@ module FatesPlantHydraulicsMod ! updated every day when trees grow or ! when recruitment happens? + ! If this is set to true, then the conductance over a path between nodes, is defined + ! by the side of the path with higher potential only. + logical, parameter :: do_upstream_k = .true. + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through ! the plant (in 1D solves) as closed from root layer @@ -165,7 +169,7 @@ module FatesPlantHydraulicsMod integer, public, parameter :: campbell_type = 2 integer, public, parameter :: tfs_type = 3 - integer, parameter :: plant_wrf_type = van_genuchten_type + integer, parameter :: plant_wrf_type = tfs_type integer, parameter :: plant_wkf_type = tfs_type ! integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wrf_type = campbell_type @@ -432,7 +436,7 @@ subroutine initTreeHydStates(site, cohort, bc_in) real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa - real(r8), parameter :: dh_dz = 0.2_r8 ! amount to decrease downstream + real(r8), parameter :: dh_dz = 0.02_r8 ! amount to decrease downstream ! compartment total potentials [MPa/meter] ! In init mode = 1, set absorbing roots to -0.2 MPa @@ -2303,7 +2307,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) logical :: recruitflag ! flag to check if there is newly recruited cohorts integer :: iter ! number of solver iterations used for each cohort x layer - integer :: nsteps ! number of substeps used for the final iteration on linear solve real(r8) :: root_flux real(r8) :: transp_flux real(r8) :: delta_plant_storage @@ -2471,7 +2474,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call MatSolve2D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake,wb_err_plant,dwat_plant,nsteps, & + sapflow,rootuptake,wb_err_plant,dwat_plant, & dth_layershell_col) else @@ -2497,9 +2500,11 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call ImTaylorSolve1D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & sapflow,rootuptake, & - wb_err_plant,dwat_plant, nsteps, & + wb_err_plant,dwat_plant, & dth_layershell_col) + + end if ! Remember the error for the cohort @@ -2563,7 +2568,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) - print*,'qflx_soil2root_sisl(j):',j,bc_out(s)%qflx_soil2root_sisl(j) +! print*,'qflx_soil2root_sisl(j):',j,bc_out(s)%qflx_soil2root_sisl(j) @@ -2595,11 +2600,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%v_shell(j,i)*AREA_INV*denh2o end if end do - - - print*,'th: ',site_hydr%h2osoi_liqvol_shell(j,:) - - enddo ! Note that the cohort-level solvers are expected to update @@ -3070,9 +3070,10 @@ end subroutine OrderLayersForSolve1D ! ================================================================================= + subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ordered,kbg_layer, sapflow,rootuptake,& - wb_err_plant,dwat_plant,nsteps,dth_layershell_col) + wb_err_plant,dwat_plant,dth_layershell_col) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -3108,28 +3109,29 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] - integer,intent(out) :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows + real(r8),intent(inout) :: dth_layershell_col(:,:) ! accumulated water content change over all cohorts in a column [m3 m-3]) ! Locals integer :: i ! node index "i" integer :: j ! path index "j" integer :: jj + integer :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows integer :: ilayer ! soil layer index of interest integer :: itest ! node index used for testing and reporting errors integer :: ishell ! rhizosphere shell index of the node - integer :: ishell_up ! rhizosphere shell index on the upper side of flow path - integer :: ishell_lo ! rhizosphere shell index on the lower side of flow path - integer :: i_up ! node index on the upper (closer to atm) side of current flow-path - integer :: i_lo ! node index on the lower (away from atm) side of current flow-path + integer :: ishell_up ! rhizosphere shell index on the upstream side of flow path (towards soil) + integer :: ishell_dn ! rhizosphere shell index on the downstream side of flow path (towards atm) + integer :: i_up ! node index on the upstream side of flow path (towards soil) + integer :: i_dn ! node index on the downstream side of flow path (towards atm) integer :: istep ! sub-step count index logical :: solution_found ! logical set to true if a solution was found within error tolerance real(r8) :: dt_step ! time [seconds] over-which to calculate solution real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] real(r8) :: rootfr_scaler ! Factor to scale down cross-section areas based on what ! fraction of root is in current layer [-] - real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] - real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] + real(r8) :: kmax_dn ! maximum conductance of downstream half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upstream half of path [kg s-1 MPa-1] real(r8) :: wb_step_err ! water balance error over substep [kg] real(r8) :: w_tot_beg ! total plant water prior to solve [kg] real(r8) :: w_tot_end ! total plant water at end of solve [kg] @@ -3191,7 +3193,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! This is the maximum number of iterations needed for this cohort ! (each soil layer has a different number, this saves the max) cohort_hydr%iterh1 = 0 - + cohort_hydr%iterh2 = 0 ! Initialize plant water error (integrated flux-storage) wb_err_plant = 0._r8 @@ -3252,7 +3254,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & wb_err_layer = 0._r8 - ! If in "spatially parallel" mode, scale down cross section ! of flux through top by the root fraction of this layer @@ -3277,7 +3278,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & q_top_eff = q_top * rootfr_scaler - + ! For all nodes leaf through rhizosphere ! Send node heights and compartment volumes to a node-based array @@ -3378,6 +3379,7 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & end do + ! Same updates as loop above, but for rhizosphere shells do i = n_hypool_plant+1,n_hypool_tot @@ -3389,15 +3391,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) end do -! print*,'init' -! print*,'psi:',psi_node(:) -! print*,'ftc:',ftc_node(:) -! print*,'h:',h_node(:) -! print*,'relsat:',th_sat_vg-th_node(1:n_hypool_plant) -! print*,'dpsidth:',dpsi_dtheta_node(:) -! print*,'dftcdth:',dftc_dtheta_node(:) -! stop - !-------------------------------------------------------------------------------- ! Part 2. Effective conductances over the path-length and Flux terms ! over the node-to-node paths @@ -3406,17 +3399,17 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Path is between the leaf node and first stem node ! ------------------------------------------------------------------------------- - j = 1 - i_up = 1 - i_lo = 2 - kmax_up = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf - kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + j = 1 + i_up = 2 ! upstream node index + i_dn = 1 ! downstream node index + kmax_dn = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) @@ -3427,24 +3420,24 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & do j=2,n_hypool_ag-1 - i_up = j - i_lo = j+1 - + i_up = j+1 + i_dn = j - ! "Up" compartment is the "upper" node, but uses - ! the "lower" side of its compartment for the calculation. - ! Ultimately, it is more "upper" than its counterpart + ! "Up" is the "upstream" node, which also uses + ! the "upper" side of its compartment for the calculation. + ! "dn" is the "downstream" node, which uses the lower + ! side of its compartment ! This compartment is the "lower" node, but uses ! the "higher" side of its compartment. - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_up-n_hypool_leaf) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_lo-n_hypool_leaf) + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_dn-n_hypool_leaf) + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_up-n_hypool_leaf) - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) @@ -3454,94 +3447,90 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & ! Path is between lowest stem and transporting root - j = n_hypool_ag - i_up = j - i_lo = j+1 - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_lo = rootfr_scaler*cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + j = n_hypool_ag + i_up = j+1 + i_dn = j + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_up = rootfr_scaler*cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) - ! Path is between the transporting root ! and the absorbing root for this layer ! NOTE: No need to scale by root fraction ! even if in parallel mode, already parallel! j = n_hypool_ag+1 - i_up = j - i_lo = j+1 - kmax_up = cohort_hydr%kmax_troot_lower(ilayer) - kmax_lo = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + i_up = j+1 + i_dn = j + kmax_dn = cohort_hydr%kmax_troot_lower(ilayer) + kmax_up = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) - ! Path is between the absorbing root ! and the first rhizosphere shell nodes - j = n_hypool_ag+2 - i_up = j - i_lo = j+1 + j = n_hypool_ag+2 + i_up = j+1 + i_dn = j ! Special case. Maximum conductance depends on the ! potential gradient. - if(h_node(i_up) < h_node(i_lo) ) then - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) + if(h_node(i_up) > h_node(i_dn) ) then + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) else - kmax_up = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) end if - kmax_lo = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) - ! Path is between rhizosphere shells do j = n_hypool_ag+3,n_hypool_tot-1 - i_up = j - i_lo = j+1 + i_up = j+1 + i_dn = j ishell_up = i_up - (n_hypool_tot-nshell) - ishell_lo = i_lo - (n_hypool_tot-nshell) + ishell_dn = i_dn - (n_hypool_tot-nshell) - kmax_up = site_hydr%kmax_lower_shell(ilayer,ishell_up)*aroot_frac_plant - kmax_lo = site_hydr%kmax_upper_shell(ilayer,ishell_lo)*aroot_frac_plant + kmax_dn = site_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant + kmax_up = site_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant - call GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_node(i_lo),ftc_node(i_up), & - h_node(i_lo),h_node(i_up), & - dftc_dtheta_node(i_lo), dftc_dtheta_node(i_up), & - dpsi_dtheta_node(i_lo), dpsi_dtheta_node(i_up), & + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & k_eff(j), & A_term(j), & B_term(j)) - end do ! ------------------------------------------------------------------------------- @@ -3683,19 +3672,12 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) end do end if - - print*,'Substep completing' end do ! do istep = 1,nsteps (substep loop) - if(.not.solution_found)then - print*,'FAILING SOLVE' - print*,dth_node(:) - end if - iter=iter+1 - end do + end do ! ----------------------------------------------------------- ! Do a final check on water balance error sumed over sub-steps @@ -3930,11 +3912,11 @@ end subroutine Report1DError ! ================================================================================= - subroutine GetImTaylorKAB(kmax_lo,kmax_up, & - ftc_lo,ftc_up, & - h_lo,h_up, & - dftc_dtheta_lo, dftc_dtheta_up, & - dpsi_dtheta_lo, dpsi_dtheta_up, & + subroutine GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_up,ftc_dn, & + h_up,h_dn, & + dftc_dtheta_up, dftc_dtheta_dn, & + dpsi_dtheta_up, dpsi_dtheta_dn, & k_eff, & a_term, & b_term) @@ -3945,35 +3927,57 @@ subroutine GetImTaylorKAB(kmax_lo,kmax_up, & ! first order expansion). The two terms are generically named A & B. ! Thus the name "KAB". These quantities are specific not to the nodes ! themselves, but to the path between the nodes, defined as positive - ! direction from "up"per (closer to atm) and "lo"wer (further from atm). + ! direction towards atmosphere, from "up"stream side (closer to soil) + ! and the "d"ow"n" stream side (closer to air) ! ----------------------------------------------------------------------------- ! Arguments - real(r8),intent(in) :: kmax_lo, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(in) :: ftc_lo, ftc_up ! frac total conductance [-] - real(r8),intent(in) :: h_lo, h_up ! total potential [Mpa] - real(r8),intent(in) :: dftc_dtheta_lo, dftc_dtheta_up ! Derivative - ! of FTC wrt relative water content - real(r8),intent(in) :: dpsi_dtheta_lo, dpsi_dtheta_up ! Derivative of matric potential - ! wrt relative water content - real(r8),intent(in) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - real(r8),intent(out) :: a_term ! "A" term for path (See tech note) - real(r8),intent(out) :: b_term ! "B" term for path (See tech note) - - ! Locals - real(r8) :: h_diff ! Total potential difference [MPa] + real(r8),intent(in) :: kmax_dn, kmax_up ! max conductance [kg s-1 Mpa-1] + real(r8),intent(inout) :: ftc_dn, ftc_up ! frac total conductance [-] + real(r8),intent(in) :: h_dn, h_up ! total potential [Mpa] + real(r8),intent(inout) :: dftc_dtheta_dn, dftc_dtheta_up ! Derivative + ! of FTC wrt relative water content + real(r8),intent(in) :: dpsi_dtheta_dn, dpsi_dtheta_up ! Derivative of matric potential + ! wrt relative water content + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(out) :: a_term ! "A" term for path (See tech note) + real(r8),intent(out) :: b_term ! "B" term for path (See tech note) + + ! Locals + real(r8) :: h_diff ! Total potential difference [MPa] ! Calculate difference in total potential over the path [MPa] - h_diff = h_lo - h_up + h_diff = h_up - h_dn + + ! If we do enable "upstream K", then we are saying that + ! the fractional loss of conductivity is dictated + ! by the upstream side of the flow. In this case, + ! the change in ftc is only non-zero on that side, and is + ! zero'd otherwise. + + if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_dn = ftc_up + dftc_dtheta_dn = 0._r8 + else + ftc_up = ftc_dn + dftc_dtheta_up = 0._r8 + end if - ! "A" term, which operates on the upper node (closer to atm) - a_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & - * dftc_dtheta_up - k_eff * dpsi_dtheta_up + end if + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + + ! "A" term, which operates on the downstream node (closer to atm) + a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn - ! "B" term, which operates on the lower node (further from atm) - b_term = k_eff**2.0_r8 * h_diff * kmax_lo**(-1.0_r8) * ftc_lo**(-2.0_r8) & - * dftc_dtheta_lo + k_eff * dpsi_dtheta_lo + ! "B" term, which operates on the upstream node (further from atm) + b_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + * dftc_dtheta_up + k_eff * dpsi_dtheta_up @@ -4018,7 +4022,7 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & ! Locals real(r8) :: h_diff ! Total potential difference [MPa] - logical, parameter :: do_upstream_k = .true. ! the effective fraction of total + ! the effective fraction of total ! conductivity is either governed ! by the upstream node, or by both ! with a harmonic average @@ -4443,7 +4447,7 @@ end subroutine Hydraulics_Tridiagonal subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & tmx,qtop, & - sapflow,rootuptake,wb_err_plant , dwat_plant,nsteps, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & dth_layershell_site) @@ -4488,13 +4492,13 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - integer,intent(out) :: nsteps ! Number of rounds of attempts we have made + real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration ! should match change in storage [kg/m2] real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] real(r8),intent(inout) :: dth_layershell_site(:,:) - + integer :: nsteps ! Number of rounds of attempts we have made integer :: i ! generic index (sometimes node index) integer :: inode ! node index integer :: k ! generic node index @@ -4616,6 +4620,10 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! This NaN's the scratch arrays call site_hydr%FlushSiteScratch() + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 ! These are output fluxes from the subroutine, total integrated ! mass fluxes [kg] over the time-step. sapflow is the integrated @@ -4989,18 +4997,17 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then psi_node(k) = psi_node(k) + residual(k) * rlfx_soil j = node_layer(k) - print*,'psi:',psi_node(k),k,j + ! print*,'psi:',psi_node(k),residual(k),k,j th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else - print*,'psi:',psi_node(k),k - print*,'residual:',residual(k) + ! print*,'psi:',psi_node(k),residual(k),k psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) endif enddo - stop +! stop endif @@ -5081,6 +5088,15 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & 201 continue + ! Save the number of substeps needed + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + + ! Save the max number of Newton iterations needed + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nwtn_iter)) + + print*,'Completed a newton solve' + print*,psi_node(:) + stop ! Save flux diagnostics ! ------------------------------------------------------ @@ -5100,6 +5116,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & end do outerloop + ! If we have made it here, we have successfully integrated ! the water content. Transfer this from scratch space @@ -5257,7 +5274,9 @@ subroutine InitHydroGlobals() integer :: ft ! PFT index integer :: pm ! plant media index integer :: inode ! compartment node index - + real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) + real(r8) :: cap_slp ! slope of capillary region of curve + real(r8) :: cap_int ! intercept of capillary region of curve if(hlm_use_planthydro.eq.ifalse) return @@ -5312,14 +5331,10 @@ subroutine InitHydroGlobals() rwcft(pm), & cap_corr, & cap_int, & - cap_slp]) + cap_slp,real(pm,r8)]) end do end do - - - write(fates_log(),*) 'TFS water retention curves not yet added to plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) end select ! ----------------------------------------------------------------------------------- diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 29b822bff0..105776cc1c 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -128,7 +128,7 @@ def __init__(self,index,th_sat,psi_sat,beta): iret = setwkf(ci(index),ci(cch_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) -class tfs_wrf: +class tfs_wrf: def __init__(self,index,th_sat,th_res,pinot,epsil,rwc_fd,cap_corr,cap_int,cap_slp,pmedia): self.th_sat = th_sat self.th_res = th_res @@ -141,14 +141,14 @@ def __init__(self,index,th_sat,th_res,pinot,epsil,rwc_fd,cap_corr,cap_int,cap_sl self.pmedia = pmedia init_wrf_args = [self.th_sat,self.th_res,self.pinot,self.epsil,self.rwc_fd,self.cap_corr,self.cap_int,self.cap_slp,self.pmedia] iret = setwrf(ci(index),ci(tfs_type),ci(len(init_wrf_args)),c8_arr(init_wrf_args)) - -class tfs_wkf: + +class tfs_wkf: def __init__(self,index,p50,avuln): self.avuln = avuln - self.p50 = p50 + self.p50 = p50 init_wkf_args = [self.p50,self.avuln] - iret = setwkf(ci(index),ci(tfs_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) - + iret = setwkf(ci(index),ci(tfs_type),ci(len(init_wkf_args)),c8_arr(init_wkf_args)) + def main(argv): @@ -208,10 +208,10 @@ def main(argv): cap_corr.append(1.0) else: cap_slp.append((hydr_psi0 - hydr_psicap )/(1.0 - rwccap[pm])) - cap_int.append(-cap_slp[pm] + hydr_psi0) + cap_int.append(-cap_slp[pm] + hydr_psi0) cap_corr.append(-cap_int[pm]/cap_slp[pm]) - - + + # Allocate memory to our objective classes iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) print('Allocated') @@ -231,10 +231,10 @@ def main(argv): tfs_wrf(4,th_sat=0.65,th_res=0.25,pinot=-1.47, \ epsil=12,rwc_fd=rwc_fd[0],cap_corr=cap_corr[0], \ cap_int=cap_int[0],cap_slp=cap_slp[0],pmedia=1) - tfs_wkf(3,p50=-2.25, avuln=2.0) + tfs_wkf(4,p50=-2.25, avuln=2.0) + - print('initialized WRF') theta = np.linspace(0.10, 0.7, num=npts) @@ -314,8 +314,8 @@ def main(argv): ax1.set_ylabel('FTC') ax1.set_xlabel('Theta [m3/m3]') - ax1.legend(loc='lower right') - + ax1.legend(loc='lower right') + # dFTC/dPSI fig3,ax1 = plt.subplots(1,1,figsize=(9,6)) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 412c3a7262..40d68ae1d0 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .false. + logical, parameter, public :: use_2d_hydrosolve = .true. ! Number of soil layers for indexing cohort fine root quanitities @@ -49,9 +49,9 @@ module FatesHydraulicsMemMod integer, parameter, public :: rhiz_p_media = 5 ! P-V curve: total RWC @ which elastic drainage begins (tfs) [-] - real(r8), parameter, public, dimension(n_porous_media) :: rwcft = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) + real(r8), parameter, public, dimension(n_plant_media) :: rwcft = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) ! P-V curve: total RWC @ which capillary reserves exhausted (tfs) - real(r8), parameter, public, dimension(n_porous_media) :: rwccap = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) + real(r8), parameter, public, dimension(n_plant_media) :: rwccap = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) ! mirror of nlevcan, hard-set for simplicity, remove nlevcan_hyd on a rainy day From 1d859175707f0270cf73bdeba97eeefcbbd3aa64 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Feb 2020 10:28:44 -0800 Subject: [PATCH 063/114] hydro: debugs and tweaks --- biogeophys/FatesPlantHydraulicsMod.F90 | 420 ++++++++++-------- .../hydro/HydroUTestDriver.py | 20 +- main/FatesHydraulicsMemMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 14 +- 4 files changed, 246 insertions(+), 210 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 30e4353dca..2f244e71f0 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -92,6 +92,7 @@ module FatesPlantHydraulicsMod use PRTGenericMod, only : store_organ, repro_organ, struct_organ use clm_time_manager , only : get_step_size, get_nstep + use EDPftvarcon, only : EDPftvarcon_inst use FatesHydroWTFMod, only : wrf_arr_type @@ -139,7 +140,11 @@ module FatesPlantHydraulicsMod ! by the side of the path with higher potential only. logical, parameter :: do_upstream_k = .true. - + logical :: purge_supersaturation = .false. ! If for some reason the roots force water + ! into a saturated soil layer, or push it slightly + ! past saturation, should we attempt to help fix the situation by assigning some + ! of the water to a runoff term? + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through ! the plant (in 1D solves) as closed from root layer ! to the stomata. The effect of this, is that @@ -153,7 +158,7 @@ module FatesPlantHydraulicsMod real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer ! is left between soil moisture and saturation [m3/m3] - + logical, parameter :: ignore_layer1 = .true. ! Ignore water uptake in first soil layer? logical,parameter :: debug = .true. !flag to report warning in hydro @@ -529,7 +534,7 @@ subroutine initTreeHydStates(site, cohort, bc_in) !initialize cohort-level btran - cohort_hydr%btran = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(1)) + cohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(1)) !flc_gs_from_psi(cohort_hydr%psi_ag(1),cohort%pft) @@ -769,6 +774,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k + integer :: j1 ! If we ignore the top soil layer, this is 2 integer :: ft ! Plant functional type index real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr @@ -799,7 +805,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) real(r8) :: v_root ! Total (aroot+troot) root volume [m3/indiv] real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] - + real(r8) :: norm ! total root fraction used <1 ccohort_hydr => ccohort%co_hydr @@ -891,30 +897,40 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & l_aroot_tot - ! Calculate Root Tissue density: - ! print*,'root tissue density: ',EDPftvarcon_inst%c2b(ft)*mg_per_kg*m3_per_mm3*fnrt_c / v_aroot_tot - + ! Total amount of root volume v_root = v_aroot_tot + v_troot ! The transporting root donates some of its volume ! to the layer-by-layer absorbing root (which is now a hybrid compartment) - ccohort_hydr%v_troot = 0.5 * v_root + ccohort_hydr%v_troot = 0.35 * v_root ! Partition the total absorbing root lengths and volumes into the active soil layers + ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - do j=1,nlevsoi_hyd + + if(ignore_layer1) then + j1 = 2 + ccohort_hydr%l_aroot_layer(1) = 0._r8 + ccohort_hydr%v_aroot_layer(1) = 0._r8 + norm = 1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(1), bc_in%zi_sisl(nlevsoi_hyd)) + else + norm = 1._r8 + j1 = 1 + end if + + do j=j1,nlevsoi_hyd if(j == 1) then rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) else rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), bc_in%zi_sisl(nlevsoi_hyd)) + zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), bc_in%zi_sisl(nlevsoi_hyd)) end if - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot -! ccohort_hydr%v_aroot_layer(j) = rootfr*v_aroot_tot + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot*norm ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(0.5*v_root) + ccohort_hydr%v_aroot_layer(j) = rootfr*(0.65*v_root) end do if(debug) then @@ -1524,7 +1540,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) - + real(r8) :: sum_l_aroot !sum of absorbing root lenghts recruitflag = .false. do s = 1,nsites csite_hydr => sites(s)%si_hydr @@ -1547,16 +1563,9 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o*currentCohort%n*AREA_INV/dtime recruitw_total = recruitw_total + recruitw + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, & - bc_in(s)%zi_sisl(j), bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j), & - bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in(s)%zi_sisl(j-1), & - bc_in(s)%zi_sisl(csite_hydr%nlevsoi_hyd)) - end if + rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & recruitw*rootfr end do @@ -1609,7 +1618,8 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) real(r8) :: rootb !root distriubiton parameter b real(r8) :: rootfr !fraction of root in different soil layer real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/individual) - real(r8) :: n, nmin !number of individuals in cohorts + real(r8) :: n, nmin !number of individuals in cohorts + real(r8) :: sum_l_aroot integer :: s, j, ft roota = EDPftvarcon_inst%roota_par(ccohort%pft) @@ -1621,18 +1631,9 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o - + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - end if - cohort_recruit_water_layer(j) = recruitw*rootfr + cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot end do do j=1,csite_hydr%nlevsoi_hyd @@ -1732,10 +1733,10 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) do j = 1,nlevsoi_hyd ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then +! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, bc_in%dz_sisl(j), & csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) - end if !has l_aroot_layer changed? +! end if !has l_aroot_layer changed? enddo @@ -2111,82 +2112,92 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) csite_hydr => sites(s)%si_hydr - do j = 1,csite_hydr%nlevsoi_hyd - cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + do j = 1,csite_hydr%nlevsoi_hyd - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j) - cumShellH2O - - dwat_kg = dwat_kgm2 * AREA - - ! order shells in terms of increasing or decreasing volumetric water content - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - if(nshell > 1) then - do k = nshell-1,1,-1 - do kk = 1,k - if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then - if (dwat_kg > 0._r8) then !order increasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - else - if (dwat_kg < 0._r8) then !order decreasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp + v_cum = sum(csite_hydr%v_shell(j,1:nshell)) + + if(v_cum < nearzero) then + + ! If we have no roots, and thus no rhizosphere, then + ! we just set the "shells" to all equal the same water content + ! m3/m3 kg/m2 * m3/kg * 1/m + csite_hydr%h2osoi_liqvol_shell(j,:) = bc_in(s)%h2o_liq_sisl(j)/(denh2o*bc_in(s)%dz_sisl(j)) + + else + + cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + + dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j) - cumShellH2O + + dwat_kg = dwat_kgm2 * AREA + + ! order shells in terms of increasing or decreasing volumetric water content + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + if(nshell > 1) then + do k = nshell-1,1,-1 + do kk = 1,k + if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + if (dwat_kg > 0._r8) then !order increasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + else + if (dwat_kg < 0._r8) then !order decreasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if end if - end if + enddo enddo - enddo - end if - - ! fill shells with water up to the water content of the next-wettest shell, - ! in order from driest to wettest (dwat_kg > 0) - ! ------ OR ------ - ! drain shells' water down to the water content of the next-driest shell, - ! in order from wettest to driest (dwat_kg < 0) - k = 1 - do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) - thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) - wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) - if(abs(dwat_kg) >= abs(wdiff)) then - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - dwat_kg = dwat_kg - wdiff - else - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & + end if + + ! fill shells with water up to the water content of the next-wettest shell, + ! in order from driest to wettest (dwat_kg > 0) + ! ------ OR ------ + ! drain shells' water down to the water content of the next-driest shell, + ! in order from wettest to driest (dwat_kg < 0) + k = 1 + do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) + thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) + if(abs(dwat_kg) >= abs(wdiff)) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) + dwat_kg = dwat_kg - wdiff + else + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum - dwat_kg = 0._r8 + dwat_kg = 0._r8 + end if + k = k + 1 + enddo + + if (dwat_kg /= 0._r8) then + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) + thdiff = dwat_kg / v_cum / denh2o + do k = nshell, 1, -1 + csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff + end do + end if + + ! m3/m3 * Total volume m3 * kg/m3 = kg + h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & + csite_hydr%v_shell(j,:) * denh2o + + + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) + + if (abs(errh2o(j)) > 1.e-9_r8) then + write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - k = k + 1 - enddo - - if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) - thdiff = dwat_kg / v_cum / denh2o - do k = nshell, 1, -1 - csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff - end do - end if - - ! m3/m3 * Total volume m3 * kg/m3 = kg - h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) * denh2o - - enddo - - ! balance check - do j = 1,csite_hydr%nlevsoi_hyd - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) - - if (abs(errh2o(j)) > 1.e-9_r8) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) end if - enddo + end do end do return @@ -2353,12 +2364,14 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) prev_h2oveg = site_hydr%h2oveg prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV + + bc_out(s)%qflx_ro_sisl(:) = 0._r8 ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- transp_flux = 0._r8 root_flux = 0._r8 - site_runoff = 0._r8 + ! Initialize the delta in soil water and plant water storage ! with the initial condition. @@ -2529,6 +2542,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call UpdateTreePsiFTCFromTheta(ccohort,site_hydr) + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + ccohort => ccohort%shorter enddo !cohort @@ -2586,25 +2601,36 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! this, if soils are pushed beyond saturation minus a small buffer ! then we remove that excess, send it to a runoff pool, and ! fix the node's water content to the saturation minus buffer value - - do i = 1,nshell - if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j)-thsat_buff)) then - - ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] - site_runoff = site_runoff + & - (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & - site_hydr%v_shell(j,i)*AREA_INV*denh2o - - site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j)-thsat_buff - print*,'runoff: ', (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & - site_hydr%v_shell(j,i)*AREA_INV*denh2o - end if - end do - enddo - + + site_runoff = 0._r8 + if(purge_supersaturation) then + do i = 1,nshell + if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j)-thsat_buff)) then + + ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] + site_runoff = site_runoff + & + (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o + + print*,'runoff [kg/m2]: ', (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o + + site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j)-thsat_buff + + end if + end do + + bc_out(s)%qflx_ro_sisl(j) = site_runoff/dtime + end if + enddo + + ! Note that the cohort-level solvers are expected to update ! site_hydr%h2oveg + ! Calculate site total kg's of runoff + site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime + delta_plant_storage = site_hydr%h2oveg - prev_h2oveg delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & @@ -2677,8 +2703,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%h2oveg_hydro_err ! [kg/m2] -> [mm/s] - bc_out(s)%qflx_ro_si = site_runoff/dtime - + ! +! if(bc_out(s)%qflx_ro_si>nearzero) print*,'sum runoff: ',site_runoff,bc_out(s)%qflx_ro_si + !write(fates_log(),*) 'hydro wb terms: --------------------------' !write(fates_log(),*) site_hydr%h2oveg !write(fates_log(),*) site_hydr%h2oveg_dead @@ -2757,7 +2784,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! soil layer [m2] real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr - + real(r8) :: sum_l_aroot ! sum of plant's total root length real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] @@ -2893,18 +2920,10 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! The max conductance of each layer is in parallel, therefore ! the kmax terms of each layer, should sum to kmax_bg + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) do j=1,csite_hydr%nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), & - bc_in%zi_sisl(csite_hydr%nlevsoi_hyd)) - end if - kmax_layer = rootfr*kmax_bg + kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot ! Two transport pathways, in two compartments exist in each layer. ! These pathways are connected in serial. @@ -2997,7 +3016,13 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ft = cohort%pft do j=1,site_hydr%nlevsoi_hyd - + + if(site_hydr%l_aroot_layer(j)1.0_r8) ) then - solution_found = .false. - error_code = 2 - error_arr(:) = th_node(:) - exit - end if +!! if( any(th_node(:)>1.0_r8) ) then +!! solution_found = .false. +!! error_code = 2 +!! error_arr(:) = th_node(:) +!! exit +!! end if !if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then @@ -3767,7 +3792,12 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & cohort_hydr%l_aroot_layer(ilayer) * & cohort%n / site_hydr%l_aroot_layer(ilayer) - + + if(j==1) then + print*,'did not exit 2' + stop + end if + enddo !soil layer (jj -> ilayer) end associate @@ -4277,35 +4307,41 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s integer :: nshells ! We don't use the global because of unit testing !----------------------------------------------------------------------- - nshells = size(r_out_shell,dim=1) - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + if(l_aroot 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + enddo + end if + + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + + do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo + + ! update volumes + do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if enddo end if - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo - - end subroutine shellGeom ! ===================================================================================== diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index 105776cc1c..afdcc5abe0 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -191,9 +191,9 @@ def main(argv): # avuln = [2.0, 2.0, 2.5, 2.5] # p50 = [-1.5, -1.5, -2.25, -2.25] - ncomp= 4 + ncomp= 2 - rwc_fd = [1.0,0.958,0.958,0.958] + rwc_fd = [1.0,0.958,0.958,0.958] rwccap = [1.0,0.947,0.947,0.947] cap_slp = [] cap_int = [] @@ -218,20 +218,20 @@ def main(argv): # Define the funcions and their parameters - vg_wrf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1) - vg_wkf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1,tort=0.5) +# vg_wrf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1) +# vg_wkf(1,alpha=1.0,psd=2.7,th_sat=0.55,th_res=0.1,tort=0.5) - cch_wrf(2,th_sat=0.55, psi_sat=-1.56e-3, beta=6) - cch_wkf(2,th_sat=0.55, psi_sat=-1.56e-3, beta=6) + cch_wrf(1,th_sat=0.55, psi_sat=-1.56e-3, beta=6) + cch_wkf(1,th_sat=0.55, psi_sat=-1.56e-3, beta=6) - cch_wrf(3,th_sat=0.55, psi_sat=-1.56e-3, beta=6) - tfs_wkf(3,p50=-2.25, avuln=2.0) +# cch_wrf(3,th_sat=0.55, psi_sat=-1.56e-3, beta=6) +# tfs_wkf(3,p50=-2.25, avuln=2.0) # Leaf - tfs_wrf(4,th_sat=0.65,th_res=0.25,pinot=-1.47, \ + tfs_wrf(2,th_sat=0.65,th_res=0.25,pinot=-1.47, \ epsil=12,rwc_fd=rwc_fd[0],cap_corr=cap_corr[0], \ cap_int=cap_int[0],cap_slp=cap_slp[0],pmedia=1) - tfs_wkf(4,p50=-2.25, avuln=2.0) + tfs_wkf(2,p50=-2.25, avuln=2.0) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 40d68ae1d0..0cc5e8de20 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .true. + logical, parameter, public :: use_2d_hydrosolve = .false. ! Number of soil layers for indexing cohort fine root quanitities diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 01455b8ed0..90c08fead8 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -567,12 +567,12 @@ module FatesInterfaceMod real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer ! [mm H2O/s] [+ into root] - real(r8),allocatable :: qflx_ro_si ! Water flux from runoff generated by - ! either plant hydraulics or dynamics + real(r8),allocatable :: qflx_ro_sisl(:) ! Water flux runoff generated by + ! root to soil flux super-saturating the soils + ! This does seem unlikely, but we need accomodate + ! small fluxes for various reasons ! [mm H2O/s] - ! In hydraulics this is possible due to super-saturation - ! in dynamics this is possible due to the release of water - ! from plant death and litter drop + end type bc_out_type @@ -862,6 +862,7 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then allocate(bc_out%qflx_soil2root_sisl(nlevsoil_in)) + allocate(bc_out%qflx_ro_sisl(nlevsoil_in)) end if return @@ -977,10 +978,9 @@ subroutine zero_bcs(this,s) if (hlm_use_planthydro.eq.itrue) then this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 - + this%bc_out(s)%qflx_ro_sisl(:) = 0.0_r8 end if this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 - this%bc_out(s)%qflx_ro_si = 0.0_r8 return end subroutine zero_bcs From 093fdca3889d8bc341abe080b517e10706519787 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 13 Feb 2020 21:06:23 -0800 Subject: [PATCH 064/114] hydro: updated some history variable definitions --- biogeophys/FatesPlantHydraulicsMod.F90 | 37 +++++++++---- .../hydro/HydroUTestDriver.py | 22 +++++--- main/FatesHistoryInterfaceMod.F90 | 54 +++++++++++++------ main/FatesHydraulicsMemMod.F90 | 11 ++-- 4 files changed, 87 insertions(+), 37 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 2f244e71f0..37c0a6d235 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -59,6 +59,7 @@ module FatesPlantHydraulicsMod use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_ipedof use FatesInterfaceMod , only : numpft + use FatesInterfaceMod , only : nlevsclass use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth @@ -1256,12 +1257,11 @@ end subroutine DeallocateHydrCohort ! ===================================================================================== - subroutine InitHydrSites(sites,bc_in,numpft) + subroutine InitHydrSites(sites,bc_in) ! Arguments type(ed_site_type),intent(inout),target :: sites(:) type(bc_in_type),intent(in) :: bc_in(:) - integer,intent(in) :: numpft ! Locals integer :: nsites @@ -1288,7 +1288,7 @@ subroutine InitHydrSites(sites,bc_in,numpft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil - call sites(s)%si_hydr%InitHydrSite() + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) @@ -2285,6 +2285,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation ! ! or sub-residual water contents from occuring in the soil [kg/m2] + integer,allocatable :: ncohorts_scpf(:,:)!nlevsclass,numpft) ! hydraulics other integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered @@ -2323,7 +2324,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: delta_plant_storage real(r8) :: delta_soil_storage real(r8) :: mean_theta ! mean water content per soil layer (testing) [m3/m3] - + integer :: sc ! size class index type(ed_site_hydr_type), pointer :: site_hydr type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: err_code = 0 @@ -2353,6 +2354,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) !update water storage in veg after incorporating newly recuited cohorts if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) + ! This helps with diagnostics + allocate(ncohorts_scpf(nlevsclass,numpft)) + do s = 1, nsites site_hydr => sites(s)%si_hydr @@ -2361,11 +2365,13 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) dth_layershell_col(:,:) = 0._r8 site_hydr%dwat_veg = 0._r8 site_hydr%errh2o_hyd = 0._r8 + ncohorts_scpf(:,:) = 0 prev_h2oveg = site_hydr%h2oveg prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV bc_out(s)%qflx_ro_sisl(:) = 0._r8 + site_hydr%sapflow(:,:) = 0._r8 ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- @@ -2432,9 +2438,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft -! ccohort_hydr%sapflow = 0._r8 ! ccohort_hydr%rootuptake = 0._r8 - ! Relative transpiration of this cohort from the whole patch ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area @@ -2533,6 +2537,12 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! Update total site-level stored plant water [kg/m2] ! (this is not zerod, but incremented) site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + + ! Sapflow diagnostic [kg/indiv/s] + ncohorts_scpf(ccohort%size_class,ft) = & + ncohorts_scpf(ccohort%size_class,ft) + 1 + site_hydr%sapflow(ccohort%size_class,ft) = & + site_hydr%sapflow(ccohort%size_class,ft) + sapflow/dtime ! --------------------------------------------------------- @@ -2705,7 +2715,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! [kg/m2] -> [mm/s] ! ! if(bc_out(s)%qflx_ro_si>nearzero) print*,'sum runoff: ',site_runoff,bc_out(s)%qflx_ro_si - !write(fates_log(),*) 'hydro wb terms: --------------------------' !write(fates_log(),*) site_hydr%h2oveg !write(fates_log(),*) site_hydr%h2oveg_dead @@ -2713,9 +2722,19 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) !write(fates_log(),*) site_hydr%h2oveg_pheno_err !write(fates_log(),*) site_hydr%h2oveg_hydro_err - + do ft = 1, numpft + do sc = 1,nlevsclass + if(ncohorts_scpf(sc,ft)>0)then + site_hydr%sapflow(sc,ft) = & + site_hydr%sapflow(sc,ft) / real(ncohorts_scpf(sc,ft),r8) + end if + end do + end do + enddo !site - + + deallocate(ncohorts_scpf) + end subroutine Hydraulics_BC ! ===================================================================================== diff --git a/functional_unit_testing/hydro/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py index afdcc5abe0..c61aa8b7a2 100644 --- a/functional_unit_testing/hydro/HydroUTestDriver.py +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -191,7 +191,7 @@ def main(argv): # avuln = [2.0, 2.0, 2.5, 2.5] # p50 = [-1.5, -1.5, -2.25, -2.25] - ncomp= 2 + ncomp= 3 rwc_fd = [1.0,0.958,0.958,0.958] rwccap = [1.0,0.947,0.947,0.947] @@ -227,13 +227,19 @@ def main(argv): # cch_wrf(3,th_sat=0.55, psi_sat=-1.56e-3, beta=6) # tfs_wkf(3,p50=-2.25, avuln=2.0) + names=['Soil','ARoot','Leaf'] + + # Absorving root + tfs_wrf(2,th_sat=0.75,th_res=0.15,pinot=-1.043478, \ + epsil=8,rwc_fd=rwc_fd[3],cap_corr=cap_corr[3], \ + cap_int=cap_int[3],cap_slp=cap_slp[3],pmedia=4) + tfs_wkf(2,p50=-2.25, avuln=2.0) + # Leaf - tfs_wrf(2,th_sat=0.65,th_res=0.25,pinot=-1.47, \ + tfs_wrf(3,th_sat=0.65,th_res=0.25,pinot=-1.47, \ epsil=12,rwc_fd=rwc_fd[0],cap_corr=cap_corr[0], \ cap_int=cap_int[0],cap_slp=cap_slp[0],pmedia=1) - tfs_wkf(2,p50=-2.25, avuln=2.0) - - + tfs_wkf(3,p50=-2.25, avuln=2.0) print('initialized WRF') @@ -251,7 +257,7 @@ def main(argv): fig0, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): - ax1.plot(theta,psi[ic,:],label='{}'.format(ic+1)) + ax1.plot(theta,psi[ic,:],label='{}'.format(names[ic])) ax1.set_ylim((-30,5)) ax1.set_ylabel('Matric Potential [MPa]') @@ -298,7 +304,7 @@ def main(argv): fig2, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): - ax1.plot(psi[ic,:],ftc[ic,:],label='{}'.format(ic+1)) + ax1.plot(psi[ic,:],ftc[ic,:],label='{}'.format(names[ic])) ax1.set_ylabel('FTC') ax1.set_xlabel('Psi [MPa]') @@ -310,7 +316,7 @@ def main(argv): fig4, ax1 = plt.subplots(1,1,figsize=(9,6)) for ic in range(ncomp): - ax1.plot(theta,ftc[ic,:],label='{}'.format(ic+1)) + ax1.plot(theta,ftc[ic,:],label='{}'.format(names[ic])) ax1.set_ylabel('FTC') ax1.set_xlabel('Theta [m3/m3]') diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index be04a48a5d..6ebeb04fe6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -427,7 +427,7 @@ module FatesHistoryInterfaceMod ! integer :: ih_rootuptake_scpf ! integer :: ih_rootuptake_sl integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension -! integer :: ih_sapflow_scpf + integer :: ih_sapflow_scpf integer :: ih_iterh1_scpf integer :: ih_iterh2_scpf integer :: ih_supsub_scpf @@ -2085,7 +2085,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) struct_c_turnover = ccohort%prt%GetTurnover(struct_organ, all_carbon_elements) * days_per_year ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] - sapw_c_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, all_carbon_elements) * days_per_year + sapw_c_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, all_carbon_elements) * days_per_year store_c_net_alloc = ccohort%prt%GetNetAlloc(store_organ, all_carbon_elements) * days_per_year leaf_c_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, all_carbon_elements) * days_per_year fnrt_c_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, all_carbon_elements) * days_per_year @@ -3255,8 +3255,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ! should be "hio_nplant_si_scpf" real(r8) :: number_fraction real(r8) :: number_fraction_rate + real(r8) :: mean_aroot integer :: ipa2 ! patch incrementer integer :: iscpf ! index of the scpf group + integer :: ipft ! index of the pft loop + integer :: iscls ! index of the size-class loop integer :: j ! soil layer index integer :: k ! rhizosphere shell index @@ -3275,7 +3278,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ! hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & ! hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & -! hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & + hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & @@ -3325,7 +3328,15 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) enddo ! cohort loop cpatch => cpatch%younger end do !patch loop + + do ipft = 1, numpft + do iscls = 1,nlevsclass + iscpf = (ipft-1)*nlevsclass + iscls + hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & + sites(s)%si_hydr%sapflow(iscls, ipft) ! [kg/indiv/s] + end do + end do ipa = 0 cpatch => sites(s)%oldest_patch @@ -3372,17 +3383,19 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ! ccohort_hydr%rootuptake(j) * number_fraction_rate ! [kg/indiv/s] ! end do -! hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & -! ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] + hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & ccohort_hydr%iterh1 * number_fraction ! [-] hio_iterh2_scpf(io_si,iscpf) = hio_iterh2_scpf(io_si,iscpf) + & ccohort_hydr%iterh2 * number_fraction ! [-] + + mean_aroot = sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & + sum(ccohort_hydr%v_aroot_layer(:)) hio_ath_scpf(io_si,iscpf) = hio_ath_scpf(io_si,iscpf) + & - ccohort_hydr%th_aroot(1) * number_fraction ! [m3 m-3] + mean_aroot * number_fraction ! [m3 m-3] hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & ccohort_hydr%th_troot * number_fraction ! [m3 m-3] @@ -3392,9 +3405,12 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_lth_scpf(io_si,iscpf) = hio_lth_scpf(io_si,iscpf) + & ccohort_hydr%th_ag(1) * number_fraction ! [m3 m-3] + + mean_aroot = sum(ccohort_hydr%psi_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & + sum(ccohort_hydr%v_aroot_layer(:)) hio_awp_scpf(io_si,iscpf) = hio_awp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_aroot(1) * number_fraction ! [MPa] + mean_aroot * number_fraction ! [MPa] hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & ccohort_hydr%psi_troot * number_fraction ! [MPa] @@ -3403,10 +3419,12 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] hio_lwp_scpf(io_si,iscpf) = hio_lwp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] - + ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] + + mean_aroot = sum(ccohort_hydr%ftc_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & + sum(ccohort_hydr%v_aroot_layer(:)) hio_aflc_scpf(io_si,iscpf) = hio_aflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_aroot(1) * number_fraction + mean_aroot * number_fraction hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & ccohort_hydr%ftc_troot * number_fraction @@ -3874,8 +3892,6 @@ subroutine define_history_vars(this, initialize_variables) long='Seed mass decay', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_elem ) - - call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & @@ -5030,10 +5046,10 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2osoi_si_scagpft ) -! call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & -! long='individual sap flow rate', use_default='inactive', & -! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) + call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & + long='individual sap flow rate', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) call this%set_history_var(vname='FATES_ITERH1_COL_SCPF', units='count/indiv/step', & long='number of outer iterations required to achieve tolerable water balance error', & @@ -5111,6 +5127,12 @@ subroutine define_history_vars(this, initialize_variables) long='mean individual level btran', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) + +! call this%set_history_var(vname='FATES_SMATPOT_SISL', units='MPa', & +! long='mean soil water matric potenial by layer', use_default='inactive', & +! avgflag='A', vtype=site_layer_r8, hlms='CLM:ALM', flushval=0.0_r8, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) + ! call this%set_history_var(vname='FATES_LAROOT_COL_SCPF', units='kg/indiv/s', & ! long='Needs Description', use_default='active', & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 0cc5e8de20..1aa0ed6737 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -142,7 +142,8 @@ module FatesHydraulicsMemMod ! Useful diagnostics ! ---------------------------------------------------------------------------------- -!! real(r8),allocatable :: sapflow(:,:) ! flow at base of tree (+ upward) [kg/cohort/s] + real(r8),allocatable :: sapflow(:,:) ! flow at base of tree (+ upward) [kg/indiv/s] + ! discretized by size x pft !! real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/cohort/s] @@ -378,11 +379,12 @@ end subroutine DeallocateHydrCohortArrays ! =================================================================================== - subroutine InitHydrSite(this) + subroutine InitHydrSite(this,numpft,numlevsclass) ! Arguments class(ed_site_hydr_type),intent(inout) :: this - + integer,intent(in) :: numpft + integer,intent(in) :: numlevsclass associate( nlevsoil_hydr => this%nlevsoi_hyd ) allocate(this%v_shell(1:nlevsoil_hydr,1:nshell)) ; this%v_shell = nan @@ -399,7 +401,8 @@ subroutine InitHydrSite(this) allocate(this%h2osoi_liq_prev(1:nlevsoil_hydr)) ; this%h2osoi_liq_prev = nan allocate(this%rs1(1:nlevsoil_hydr)); this%rs1(:) = fine_root_radius_const allocate(this%recruit_w_uptake(1:nlevsoil_hydr)); this%recruit_w_uptake = nan - + allocate(this%sapflow(1:numlevsclass,1:numpft)); this%sapflow = nan + this%errh2o_hyd = nan this%dwat_veg = nan this%h2oveg = 0.0_r8 From 3b26309b447ba290e63cd11bc74bacdc7eda6e5c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 17 Feb 2020 15:52:11 -0800 Subject: [PATCH 065/114] bug fixed rhizosphere layer dimensioning. --- biogeochem/EDCohortDynamicsMod.F90 | 14 +- biogeophys/FatesPlantHydraulicsMod.F90 | 699 ++++++++++--------------- main/FatesHistoryInterfaceMod.F90 | 30 +- main/FatesHydraulicsMemMod.F90 | 183 +++---- main/FatesInterfaceMod.F90 | 10 +- main/FatesRestartInterfaceMod.F90 | 8 +- 6 files changed, 418 insertions(+), 526 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index b324464d05..b8ecd8d510 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -41,7 +41,7 @@ module EDCohortDynamicsMod use FatesPlantHydraulicsMod, only : FuseCohortHydraulics use FatesPlantHydraulicsMod, only : CopyCohortHydraulics use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps - use FatesPlantHydraulicsMod, only : initTreeHydStates + use FatesPlantHydraulicsMod, only : InitTreeHydStates use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesPlantHydraulicsMod, only : DeallocateHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage @@ -182,7 +182,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & integer :: iage ! loop counter for leaf age classes real(r8) :: leaf_c ! total leaf carbon integer :: tnull,snull ! are the tallest and shortest cohorts allocate - integer :: nlevsoi_hyd ! number of hydraulically active soil layers + integer :: nlevrhiz ! number of rhizosphere layers !---------------------------------------------------------------------- @@ -287,20 +287,20 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & if( hlm_use_planthydro.eq.itrue ) then - nlevsoi_hyd = currentSite%si_hydr%nlevsoi_hyd + nlevrhiz = currentSite%si_hydr%nlevrhiz ! This allocates array spaces call InitHydrCohort(currentSite,new_cohort) ! This calculates node heights call UpdateTreeHydrNodes(new_cohort%co_hydr,new_cohort%pft, & - new_cohort%hite,nlevsoi_hyd,bc_in) + new_cohort%hite,currentSite%si_hydr) ! This calculates volumes and lengths - call UpdateTreeHydrLenVol(new_cohort,nlevsoi_hyd,bc_in) + call UpdateTreeHydrLenVol(new_cohort,currentSite%si_hydr) ! This updates the Kmax's of the plant's compartments - call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr,bc_in) + call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. @@ -308,7 +308,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & ! This comes up with starter suctions and then water contents ! based on the soil values - call initTreeHydStates(currentSite,new_cohort, bc_in) + call InitTreeHydStates(currentSite,new_cohort) if(recruitstatus==1)then diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 37c0a6d235..b212687f4e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -87,6 +87,7 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: cohort_recruit_water_layer use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft + use FatesHydraulicsMemMod, only: ignore_layer1 use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ @@ -159,8 +160,6 @@ module FatesPlantHydraulicsMod real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer ! is left between soil moisture and saturation [m3/m3] - logical, parameter :: ignore_layer1 = .true. ! Ignore water uptake in first soil layer? - logical,parameter :: debug = .true. !flag to report warning in hydro @@ -215,7 +214,7 @@ module FatesPlantHydraulicsMod public :: updateSizeDepTreeHydProps public :: updateSizeDepTreeHydStates public :: UpdateTreePsiFTCFromTheta - public :: initTreeHydStates + public :: InitTreeHydStates public :: updateSizeDepRhizHydProps public :: updateSizeDepRhizHydStates public :: RestartHydrStates @@ -232,11 +231,7 @@ module FatesPlantHydraulicsMod ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen !------------------------------------------------------------------------------ -contains - - - - +contains !------------------------------------------------------------------------------ subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) @@ -298,15 +293,18 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) type(ed_patch_type),pointer :: cpatch ! current patch type(ed_cohort_type),pointer :: ccohort ! current cohort type(ed_cohort_hydr_type),pointer :: ccohort_hydr + type(ed_site_hydr_type),pointer :: csite_hydr integer :: s ! site loop counter integer :: j + integer :: j_bc ! soil layer index of boundary condition class(wrf_type_vg), pointer :: wrf_vg class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch class(wkf_type_cch), pointer :: wkf_cch do s = 1,nsites - + csite_hydr=>sites(s)%si_hydr + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -317,13 +315,13 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! This calculates node heights call UpdateTreeHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & - sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) + sites(s)%si_hydr) ! This calculates volumes and lengths - call UpdateTreeHydrLenVol(ccohort,sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) + call UpdateTreeHydrLenVol(ccohort,csite_hydr) ! This updates the Kmax's of the plant's compartments - call UpdatePlantKmax(ccohort_hydr,ccohort,sites(s)%si_hydr,bc_in(s)) + call UpdatePlantKmax(ccohort_hydr,ccohort,sites(s)%si_hydr) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. @@ -352,18 +350,20 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) select case(soil_wrf_type) case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 allocate(wrf_vg) sites(s)%si_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, bc_in(s)%watsat_sisl(j), th_res_vg]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, bc_in(s)%watsat_sisl(j_bc), th_res_vg]) end do case(campbell_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 allocate(wrf_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_cch - call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j)]) + call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' @@ -376,18 +376,20 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) select case(soil_wkf_type) case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 allocate(wkf_vg) sites(s)%si_hydr%wkf_soil(j)%p => wkf_vg call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) end do case(campbell_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 allocate(wkf_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_cch - call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j)]) + call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' @@ -404,7 +406,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! the previous call to make sure that the conductances are updated ! Now we set the prevous to the current so that the water states ! are not perturbed - call SavePreviousRhizVolumes(sites(s), bc_in(s)) + call SavePreviousRhizVolumes(sites(s)) end do @@ -415,7 +417,7 @@ end subroutine RestartHydrStates ! ==================================================================================== - subroutine initTreeHydStates(site, cohort, bc_in) + subroutine InitTreeHydStates(site, cohort) ! REQUIRED INPUTS: ! @@ -430,7 +432,6 @@ subroutine initTreeHydStates(site, cohort, bc_in) ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: site ! current site pointer type(ed_cohort_type), intent(inout), target :: cohort ! current cohort pointer - type(bc_in_type) , intent(in) :: bc_in ! input boundary condition ! ! !LOCAL VARIABLES: type(ed_site_hydr_type), pointer :: site_hydr @@ -463,13 +464,13 @@ subroutine initTreeHydStates(site, cohort, bc_in) h_aroot_mean = 0._r8 - do j=1, site_hydr%nlevsoi_hyd + do j=1, site_hydr%nlevrhiz ! Match the potential of the absorbing root to the inner rhizosphere shell cohort_hydr%psi_aroot(j) = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) ! Calculate the mean total potential (include height) of absorbing roots - h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-bc_in%z_sisl(j)) + h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) @@ -477,16 +478,16 @@ subroutine initTreeHydStates(site, cohort, bc_in) else - do j=1, site_hydr%nlevsoi_hyd + do j=1, site_hydr%nlevrhiz cohort_hydr%psi_aroot(j) = psi_aroot_init ! Calculate the mean total potential (include height) of absorbing roots - h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-bc_in%z_sisl(j)) + h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - h_aroot_mean = h_aroot_mean/real(site_hydr%nlevsoi_hyd,r8) + h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) ! the assumption is made here that initial conditions for soil water will @@ -553,7 +554,7 @@ subroutine initTreeHydStates(site, cohort, bc_in) - end subroutine initTreeHydStates + end subroutine InitTreeHydStates ! ===================================================================================== @@ -594,7 +595,7 @@ subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) ! Update the Psi and FTC for the absorbing roots - do j = 1, csite_hydr%nlevsoi_hyd + do j = 1, csite_hydr%nlevrhiz ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do @@ -606,7 +607,7 @@ end subroutine UpdateTreePsiFTCFromTheta ! ===================================================================================== - subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) + subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! This subroutine calculates the nodal heights critical to hydraulics in the plant @@ -626,12 +627,11 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) type(ed_cohort_hydr_type), intent(inout) :: ccohort_hydr integer,intent(in) :: ft ! plant functional type index real(r8), intent(in) :: plant_height ! [m] - integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions + type(ed_site_hydr_type), intent(in) :: csite_hydr ! Locals - + integer :: nlevrhiz ! number of rhizosphere layers real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr real(r8) :: crown_depth ! crown depth for the plant [m] @@ -647,9 +647,9 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) ! in special case where n_hypool_leaf = 1, the node height of the canopy ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) - + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) + nlevrhiz = csite_hydr%nlevrhiz call CrownDepth(plant_height,crown_depth) dz_canopy = crown_depth / real(n_hypool_leaf,r8) @@ -675,16 +675,9 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,nlevsoi_hyd,bc_in) call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) - z_cumul_rf = min(z_cumul_rf, abs(bc_in%zi_sisl(nlevsoi_hyd))) + z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) ccohort_hydr%z_node_troot = -z_cumul_rf - - !write(fates_log(),*)'h: ',plant_height - !write(fates_log(),*)'z upper: ', ccohort_hydr%z_upper_ag - !write(fates_log(),*)'z nodes: ', ccohort_hydr%z_node_ag - !write(fates_log(),*)'z lower: ', ccohort_hydr%z_lower_ag - !write(fates_log(),*)'z troot: ', ccohort_hydr%z_node_troot - - + return end subroutine UpdateTreeHydrNodes @@ -724,11 +717,11 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions ! Locals - integer :: nlevsoi_hyd ! Number of total soil layers + integer :: nlevrhiz ! Number of total soil layers type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: ft - nlevsoi_hyd = currentSite%si_hydr%nlevsoi_hyd + nlevrhiz = currentSite%si_hydr%nlevrhiz ccohort_hydr => ccohort%co_hydr ft = ccohort%pft @@ -738,23 +731,23 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdateTreeHydrNodes(ccohort_hydr,ft,ccohort%hite,nlevsoi_hyd,bc_in) + call UpdateTreeHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdateTreeHydrNodes is called prior to this. - call UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) + call UpdateTreeHydrLenVol(ccohort,currentSite%si_hydr) ! This updates the Kmax's of the plant's compartments - call UpdatePlantKmax(ccohort_hydr,ccohort,currentsite%si_hydr,bc_in) + call UpdatePlantKmax(ccohort_hydr,ccohort,currentsite%si_hydr) end subroutine updateSizeDepTreeHydProps ! ===================================================================================== - subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) + subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) ! ----------------------------------------------------------------------------------- ! This subroutine calculates two attributes of a plant: @@ -770,12 +763,10 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! Arguments type(ed_cohort_type),intent(inout) :: ccohort - integer,intent(in) :: nlevsoi_hyd ! number of soil hydro layers - type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions - + type(ed_site_hydr_type),intent(in) :: site_hydr + type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k - integer :: j1 ! If we ignore the top soil layer, this is 2 integer :: ft ! Plant functional type index real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr @@ -807,11 +798,11 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] real(r8) :: norm ! total root fraction used <1 - + integer :: nlevrhiz ! number of rhizosphere levels ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - + nlevrhiz = site_hydr%nlevrhiz leaf_c = ccohort%prt%GetState(leaf_organ, all_carbon_elements) sapw_c = ccohort%prt%GetState(sapw_organ, all_carbon_elements) fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) @@ -910,48 +901,20 @@ subroutine UpdateTreeHydrLenVol(ccohort,nlevsoi_hyd,bc_in) ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - if(ignore_layer1) then - j1 = 2 - ccohort_hydr%l_aroot_layer(1) = 0._r8 - ccohort_hydr%v_aroot_layer(1) = 0._r8 - norm = 1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(1), bc_in%zi_sisl(nlevsoi_hyd)) - else - norm = 1._r8 - j1 = 1 - end if + norm = 1._r8 - & + zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) - do j=j1,nlevsoi_hyd - if(j == 1) then - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) - else - rootfr = zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j), bc_in%zi_sisl(nlevsoi_hyd)) - & - zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(j-1), bc_in%zi_sisl(nlevsoi_hyd)) - end if + do j=1,nlevrhiz - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot*norm + rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & + zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot ! This is a hybrid absorbing root and transporting root volume ccohort_hydr%v_aroot_layer(j) = rootfr*(0.65*v_root) end do - if(debug) then - if(abs(1._r8-zeng2001_crootfr(roota, rootb, bc_in%zi_sisl(nlevsoi_hyd), & - bc_in%zi_sisl(nlevsoi_hyd)))>rsnbl_math_prec) then - write(fates_log(),*) 'The Zeng 2001 root layering scheme should' - write(fates_log(),*) 'have an integrated root fraction at the lowest soil layer' - write(fates_log(),*) 'crootfr: ',zeng2001_crootfr(roota, rootb, & - bc_in%zi_sisl(nlevsoi_hyd), bc_in%zi_sisl(nlevsoi_hyd)) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - !write(fates_log(),*)'vols: ', ccohort_hydr%v_ag,ccohort_hydr%v_troot - !write(fates_log(),*)'v_aroot: ', ccohort_hydr%v_aroot_layer(:) - !write(fates_log(),*)'l_aroot: ', ccohort_hydr%l_aroot_layer(:) - - - - end if !check for bleaf end subroutine UpdateTreeHydrLenVol @@ -976,7 +939,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) integer :: err_code = 0 real(r8) :: th_ag_uncorr( n_hypool_ag) ! uncorrected aboveground water content[m3 m-3] real(r8) :: th_troot_uncorr ! uncorrected transporting root water content[m3 m-3] - real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevsoi_hyd) ! uncorrected absorbing root water content[m3 m-3] + real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevrhiz) ! uncorrected absorbing root water content[m3 m-3] real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] integer :: nstep !number of time steps @@ -1003,7 +966,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ccohort_hydr%errh2o_growturn_aroot = 0._r8 - do j=1,currentSite%si_hydr%nlevsoi_hyd + do j=1,currentSite%si_hydr%nlevrhiz th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, pm_node(4)) @@ -1185,7 +1148,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) - do j=1,site_hydr%nlevsoi_hyd + do j=1,site_hydr%nlevrhiz ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do @@ -1233,7 +1196,7 @@ subroutine InitHydrCohort(currentSite,currentCohort) if ( hlm_use_planthydro.eq.ifalse ) return allocate(ccohort_hydr) currentCohort%co_hydr => ccohort_hydr - call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevsoi_hyd) + call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) ccohort_hydr%is_newly_recruited = .false. @@ -1266,7 +1229,8 @@ subroutine InitHydrSites(sites,bc_in) ! Locals integer :: nsites integer :: s - integer :: j + integer :: j + integer :: jj type(ed_site_hydr_type),pointer :: csite_hydr @@ -1287,10 +1251,26 @@ subroutine InitHydrSites(sites,bc_in) write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - sites(s)%si_hydr%nlevsoi_hyd = bc_in(s)%nlevsoil - call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) + ! Calculate the number of rhizosphere + ! layers used + if(ignore_layer1) then + csite_hydr%i_rhiz_t = 2 + csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil + else + csite_hydr%i_rhiz_t = 1 + csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil + end if + + csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) + jj=1 + do j=csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b + csite_hydr%zi_rhiz(jj) = bc_in(s)%zi_sisl(j) + csite_hydr%dz_rhiz(jj) = bc_in(s)%dz_sisl(j) + jj=jj+1 + end do end do @@ -1309,10 +1289,9 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) real(r8) :: smp ! matric potential temp real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) integer :: s - integer :: j + integer :: j,j_bc integer :: nsites - integer :: nlevsoil ! Number of soil layers - integer :: nlevsoil_hyd ! Number of hydraulically relevant soil layers + integer :: nlevrhiz class(wrf_type_vg), pointer :: wrf_vg class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch @@ -1322,29 +1301,21 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) nsites = ubound(sites,1) do s = 1,nsites - site_hydr => sites(s)%si_hydr - - nlevsoil = bc_in(s)%nlevsoil - nlevsoil_hyd = site_hydr%nlevsoi_hyd - - if ( nlevsoil_hyd == 1) then - - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(nlevsoil), & - bc_in(s)%h2o_liq_sisl(nlevsoil)/(bc_in(s)%dz_sisl(nlevsoil)*denh2o)) - - site_hydr%h2osoi_liqvol_shell(nlevsoil_hyd,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(nlevsoil_hyd) = bc_in(s)%h2o_liq_sisl(nlevsoil) - else - do j = 1,nlevsoil_hyd - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j), & - bc_in(s)%h2o_liq_sisl(j)/(bc_in(s)%dz_sisl(j)*denh2o)) - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - end do - end if + site_hydr => sites(s)%si_hydr + nlevrhiz = site_hydr%nlevrhiz + + do j = 1,nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j_bc), & + bc_in(s)%h2o_liq_sisl(j_bc)/(site_hydr%dz_rhiz(j)*denh2o)) + + site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + end do + - site_hydr%l_aroot_layer(1:site_hydr%nlevsoi_hyd) = 0.0_r8 + site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 ! -------------------------------------------------------------------------------- @@ -1358,18 +1329,20 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) select case(soil_wrf_type) case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 allocate(wrf_vg) site_hydr%wrf_soil(j)%p => wrf_vg call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) end do case(campbell_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,site_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 allocate(wrf_cch) site_hydr%wrf_soil(j)%p => wrf_cch - call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j)]) + call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' @@ -1382,27 +1355,25 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) select case(soil_wkf_type) case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd + do j=1,sites(s)%si_hydr%nlevrhiz allocate(wkf_vg) site_hydr%wkf_soil(j)%p => wkf_vg call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) end do - case(campbell_type) - do j=1,sites(s)%si_hydr%nlevsoi_hyd - allocate(wkf_cch) - site_hydr%wkf_soil(j)%p => wkf_cch - call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j)]) + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wkf_cch) + site_hydr%wkf_soil(j)%p => wkf_cch + call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & + (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bc_in(s)%bsw_sisl(j_bc)]) end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - - - end do ! @@ -1564,7 +1535,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) denh2o*currentCohort%n*AREA_INV/dtime recruitw_total = recruitw_total + recruitw sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & recruitw*rootfr @@ -1579,7 +1550,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) sumrw_uptake = sum(csite_hydr%recruit_w_uptake) err = recruitw_total - sumrw_uptake if(abs(err)>1.0e-10_r8)then - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake enddo @@ -1632,12 +1603,11 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot end do - do j=1,csite_hydr%nlevsoi_hyd - + do j=1,csite_hydr%nlevrhiz watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) @@ -1649,7 +1619,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) end do nmin = 1.0e+36 - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz if(cohort_recruit_water_layer(j)>0.0_r8) then n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) nmin = min(n, nmin) @@ -1662,17 +1632,13 @@ end subroutine ConstrainRecruitNumber ! ===================================================================================== - subroutine SavePreviousRhizVolumes(currentSite, bc_in) + subroutine SavePreviousRhizVolumes(currentSite) ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in type(ed_site_hydr_type), pointer :: csite_hydr - integer :: nlevsoi_hyd csite_hydr => currentSite%si_hydr - nlevsoi_hyd = csite_hydr%nlevsoi_hyd - csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) @@ -1706,16 +1672,17 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) real(r8) :: hksat_s ! hksat converted to units of 10^6sec ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices + integer :: j_bc ! soil layer index of boundary condition real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the ! innermost shell radius is less than the assumed ! absorbing root radius rs1 ! 1.e-5_r8 from Rudinger et al 1994 - integer :: nlevsoi_hyd + integer :: nlevrhiz integer, parameter :: k_inner = 1 ! innermost rhizosphere shell !----------------------------------------------------------------------- csite_hydr => currentSite%si_hydr - nlevsoi_hyd = csite_hydr%nlevsoi_hyd + nlevrhiz = csite_hydr%nlevrhiz ! update cohort-level root length density and accumulate it across cohorts and patches to the column level csite_hydr%l_aroot_layer(:) = 0._r8 @@ -1731,16 +1698,17 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) enddo !patch ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - do j = 1,nlevsoi_hyd + do j = 1,nlevrhiz ! proceed only if l_aroot_coh has changed -! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, bc_in%dz_sisl(j), & + ! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, csite_hydr%dz_rhiz(j), & csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) ! end if !has l_aroot_layer changed? enddo - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) ! @@ -1754,8 +1722,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! * 1e6 [Pa MPa-1] ! = [kg s-1 m-1 MPa-1] - hksat_s = bc_in%hksat_sisl(j) * m_per_mm * 1._r8/grav_earth * pa_per_mpa - + hksat_s = bc_in%hksat_sisl(j_bc) * m_per_mm * 1._r8/grav_earth * pa_per_mpa + ! proceed only if the total absorbing root length (site-level) has changed in this layer if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then @@ -1811,7 +1779,7 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) ! Save current volumes, lenghts and nodes to an "initial" ! used to calculate effects in states later on. - call SavePreviousRhizVolumes(currentSite, bc_in) + call SavePreviousRhizVolumes(currentSite) ! Update the properties of the vegetation-soil hydraulic environment ! these are independent on the water state @@ -1853,6 +1821,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) real(r8) :: delta_s(nlevsoi_hyd_max) ! change in saturation fraction needed to ensure water bal [0-1] real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] integer :: j,k ! gridcell, column, soil layer, rhizosphere shell indicies + integer :: j_bc ! level index for boundary conditions integer :: indexc,indexj ! column and layer indices where there is a water balance error logical :: found ! flag in search loop type(ed_site_hydr_type), pointer :: csite_hydr @@ -1867,7 +1836,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) if(.false.) then - do j = 1, csite_hydr%nlevsoi_hyd + do j = 1, csite_hydr%nlevrhiz ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then @@ -1880,7 +1849,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) ! interpolate initial psi values by layer and shell ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,csite_hydr%nlevrhiz ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then @@ -1930,18 +1899,21 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) enddo ! 1st guess at new s based on interpolated psi - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j)) / & - (bc_in%watres_sisl(j)+bc_in%watres_sisl(j)) + s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j_bc)) / & + (bc_in%watres_sisl(j_bc)+bc_in%watres_sisl(j_bc)) end if !has l_aroot_coh changed? enddo ! accumlate water across shells for each layer (initial and interpolated) - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then w_layer_init(j) = 0._r8 @@ -1952,7 +1924,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) (csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) w_layer_interp(j) = w_layer_interp(j) + denh2o * & (csite_hydr%v_shell(j,k) * & - (s_shell_interp(j,k)*(bc_in%watsat_sisl(j)-bc_in%watres_sisl(j))+bc_in%watres_sisl(j)) ) + (s_shell_interp(j,k)*(bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc))+bc_in%watres_sisl(j_bc)) ) v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) enddo end if !has l_aroot_coh changed? @@ -1960,23 +1932,25 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j)) / & - (bc_in%watsat_sisl(j)-bc_in%watres_sisl(j)) + delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j_bc)) / & + (bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc)) end if !has l_aroot_coh changed? enddo ! update h2osoi_liqvol_shell and h2osoi_liq_shell - do j = 1,csite_hydr%nlevsoi_hyd + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then w_layer_new(j) = 0._r8 do k = 1,nshell s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & - ( bc_in%watsat_sisl(j)-bc_in%watres_sisl(j) ) + bc_in%watres_sisl(j) + ( bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc) ) + bc_in%watres_sisl(j_bc) w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & csite_hydr%v_shell(j,k) w_layer_new(j) = w_layer_new(j) + w_shell_new @@ -1986,8 +1960,9 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) enddo ! balance check - do j = 1,csite_hydr%nlevsoi_hyd - errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j) + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) if (abs(errh2o(j)) > 1.e-4_r8) then write(fates_log(),*)'WARNING: water balance error ',& ' updating rhizosphere shells: ',j,errh2o(j) @@ -2085,6 +2060,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) type(ed_site_hydr_type), pointer :: csite_hydr integer :: s,j,k ! site, soil layer, rhizosphere shell indicies integer :: i,f,ff,kk ! indicies + integer :: j_bc ! layer index for matching boundary condition soil layers integer :: indexj ! column and layer indices where there is a water balance error integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered real(r8) :: area_col ! column area [m2] @@ -2112,90 +2088,79 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) csite_hydr => sites(s)%si_hydr - do j = 1,csite_hydr%nlevsoi_hyd - - v_cum = sum(csite_hydr%v_shell(j,1:nshell)) - - if(v_cum < nearzero) then + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 - ! If we have no roots, and thus no rhizosphere, then - ! we just set the "shells" to all equal the same water content - ! m3/m3 kg/m2 * m3/kg * 1/m - csite_hydr%h2osoi_liqvol_shell(j,:) = bc_in(s)%h2o_liq_sisl(j)/(denh2o*bc_in(s)%dz_sisl(j)) - - else - - cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV - - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j) - cumShellH2O + cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + + dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O - dwat_kg = dwat_kgm2 * AREA - - ! order shells in terms of increasing or decreasing volumetric water content - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - if(nshell > 1) then - do k = nshell-1,1,-1 - do kk = 1,k - if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then - if (dwat_kg > 0._r8) then !order increasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - else - if (dwat_kg < 0._r8) then !order decreasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if + dwat_kg = dwat_kgm2 * AREA + + ! order shells in terms of increasing or decreasing volumetric water content + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + if(nshell > 1) then + do k = nshell-1,1,-1 + do kk = 1,k + if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + if (dwat_kg > 0._r8) then !order increasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + else + if (dwat_kg < 0._r8) then !order decreasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp end if - enddo + end if enddo - end if - - ! fill shells with water up to the water content of the next-wettest shell, - ! in order from driest to wettest (dwat_kg > 0) - ! ------ OR ------ - ! drain shells' water down to the water content of the next-driest shell, - ! in order from wettest to driest (dwat_kg < 0) - k = 1 - do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) - thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) - wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) - if(abs(dwat_kg) >= abs(wdiff)) then - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - dwat_kg = dwat_kg - wdiff - else - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum - dwat_kg = 0._r8 - end if - k = k + 1 enddo - - if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) - thdiff = dwat_kg / v_cum / denh2o - do k = nshell, 1, -1 - csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff - end do - end if - - ! m3/m3 * Total volume m3 * kg/m3 = kg - h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) * denh2o - - - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j) - - if (abs(errh2o(j)) > 1.e-9_r8) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! fill shells with water up to the water content of the next-wettest shell, + ! in order from driest to wettest (dwat_kg > 0) + ! ------ OR ------ + ! drain shells' water down to the water content of the next-driest shell, + ! in order from wettest to driest (dwat_kg < 0) + k = 1 + do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) + thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) + if(abs(dwat_kg) >= abs(wdiff)) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) + dwat_kg = dwat_kg - wdiff + else + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum + dwat_kg = 0._r8 end if + k = k + 1 + enddo + + if (dwat_kg /= 0._r8) then + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) + thdiff = dwat_kg / v_cum / denh2o + do k = nshell, 1, -1 + csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff + end do + end if + + ! m3/m3 * Total volume m3 * kg/m3 = kg + h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & + csite_hydr%v_shell(j,:) * denh2o + + + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) + + if (abs(errh2o(j)) > 1.e-9_r8) then + write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do @@ -2205,7 +2170,7 @@ end subroutine FillDrainRhizShells ! ==================================================================================== - subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) + subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! ---------------------------------------------------------------------------------- ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics @@ -2240,6 +2205,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) integer :: s ! index of FATES site integer :: i ! shell index integer :: j,jj! soil layer + integer :: j_bc! soil layer index for boundary conditions integer :: k ! 1D plant-soil continuum array integer :: ft ! plant functional type index integer :: t ! previous timesteps (for lwp stability calculation) @@ -2311,6 +2277,8 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) real(r8) :: smp ! temporary for matric potential (MPa) integer :: tmp + integer :: jtop, jbot ! indices of the top and bottom rhizosphere layer + ! relative to the boundary condition array real(r8) :: tmp1 real(r8) :: watres_local real(r8) :: roota, rootb ! parameters for root distribution [m-1] @@ -2489,7 +2457,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) if(use_2d_hydrosolve) then - call MatSolve2D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & + call MatSolve2D(site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake,wb_err_plant,dwat_plant, & dth_layershell_col) @@ -2514,7 +2482,7 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) - call ImTaylorSolve1D(site_hydr,bc_in(s),ccohort,ccohort_hydr, & + call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & sapflow,rootuptake, & wb_err_plant,dwat_plant, & @@ -2572,35 +2540,27 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) ! water contents. But the pre-adjusted value is the actual amount of root flux. ! [kg/m2] - root_flux = -sum(dth_layershell_col(1:site_hydr%nlevsoi_hyd,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - do j=1,site_hydr%nlevsoi_hyd - + do j=1,site_hydr%nlevrhiz + j_bc = j+site_hydr%i_rhiz_t-1 + ! Update the site-level state variable ! rhizosphere shell water content [m3/m3] site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & dth_layershell_col(j,:) - if(site_hydr%recruit_w_uptake(j) > nearzero) then - write(fates_log(),*) 'turn off recruitment for now' - write(fates_log(),*) 'can turn on again after results stabilize' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - bc_out(s)%qflx_soil2root_sisl(j) = & + bc_out(s)%qflx_soil2root_sisl(j_bc) = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) - -! print*,'qflx_soil2root_sisl(j):',j,bc_out(s)%qflx_soil2root_sisl(j) - ! Save the amount of liquid soil water known to the model after root uptake ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j) + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j_bc) ! We accept that it is possible for gravity to push @@ -2615,22 +2575,19 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_runoff = 0._r8 if(purge_supersaturation) then do i = 1,nshell - if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j)-thsat_buff)) then + if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) then ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] site_runoff = site_runoff + & - (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & + (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) * & site_hydr%v_shell(j,i)*AREA_INV*denh2o - print*,'runoff [kg/m2]: ', (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j)-thsat_buff)) * & - site_hydr%v_shell(j,i)*AREA_INV*denh2o - - site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j)-thsat_buff + site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j_bc)-thsat_buff end if end do - bc_out(s)%qflx_ro_sisl(j) = site_runoff/dtime + bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime end if enddo @@ -2673,7 +2630,9 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) !remove the recruitment water uptake as it has been added to prev_h2oveg - totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(:) - & + jtop = site_hydr%i_rhiz_t + jbot = site_hydr%i_rhiz_b + totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(jtop:jbot) - & site_hydr%recruit_w_uptake(:))*dtime @@ -2712,16 +2671,6 @@ subroutine hydraulics_bc ( nsites, sites,bc_in,bc_out,dtime ) site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err - ! [kg/m2] -> [mm/s] - ! -! if(bc_out(s)%qflx_ro_si>nearzero) print*,'sum runoff: ',site_runoff,bc_out(s)%qflx_ro_si - !write(fates_log(),*) 'hydro wb terms: --------------------------' - !write(fates_log(),*) site_hydr%h2oveg - !write(fates_log(),*) site_hydr%h2oveg_dead - !write(fates_log(),*) site_hydr%h2oveg_growturn_err - !write(fates_log(),*) site_hydr%h2oveg_pheno_err - !write(fates_log(),*) site_hydr%h2oveg_hydro_err - do ft = 1, numpft do sc = 1,nlevsclass if(ncohorts_scpf(sc,ft)>0)then @@ -2741,7 +2690,7 @@ end subroutine Hydraulics_BC - subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) + subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) ! --------------------------------------------------------------------------------- ! @@ -2771,9 +2720,6 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr type(ed_cohort_type),intent(in),target :: ccohort type(ed_site_hydr_type),intent(in),target :: csite_hydr - type(bc_in_type),intent(in) :: bc_in - - ! Locals integer :: k ! Compartment (node) index @@ -2940,7 +2886,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! The max conductance of each layer is in parallel, therefore ! the kmax terms of each layer, should sum to kmax_bg sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot @@ -2970,7 +2916,7 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) ! or in-to the root). So we calculate the kmax's for both cases, ! and save them for the final conductance calculation. - do j=1,csite_hydr%nlevsoi_hyd + do j=1,csite_hydr%nlevrhiz ! Surface area of the absorbing roots for a single plant in this layer [m2] surfarea_aroot_layer = 2._r8 * pi_const * & @@ -2983,14 +2929,6 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr,bc_in) end do - !write(fates_log(),*) 'ksu:',ccohort_hydr%kmax_stem_upper(:) - !write(fates_log(),*) 'ksl:',ccohort_hydr%kmax_stem_lower(:) - !write(fates_log(),*) 'ktu: ',ccohort_hydr%kmax_troot_upper - !write(fates_log(),*) 'ktl:',ccohort_hydr%kmax_troot_lower(:) - !write(fates_log(),*) 'kau',ccohort_hydr%kmax_aroot_upper(:) - !write(fates_log(),*) 'kri:',ccohort_hydr%kmax_aroot_radial_in(:) - !write(fates_log(),*) 'kro:',ccohort_hydr%kmax_aroot_radial_out(:) - return end subroutine UpdatePlantKmax @@ -3010,7 +2948,6 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ! Locals -! real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating ! which kmax to use when forecasting uptake layer ordering [MPa] @@ -3034,14 +2971,8 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ft = cohort%pft - do j=1,site_hydr%nlevsoi_hyd - - if(site_hydr%l_aroot_layer(j)max_iter)then - call Report1DError(cohort,site_hydr,bc_in,ilayer,z_node,v_node, & + call Report1DError(cohort,site_hydr,ilayer,z_node,v_node, & th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& rootfr_scaler,aroot_frac_plant,error_code,error_arr) @@ -3652,31 +3572,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) end do - ! We currently allow super-saturation, but draw the line - ! at 100% of volume... -!! if( any(th_node(:)>1.0_r8) ) then -!! solution_found = .false. -!! error_code = 2 -!! error_arr(:) = th_node(:) -!! exit -!! end if - - - !if( any(th_node(n_hypool_ag+3:n_hypool_tot)>bc_in%watsat_sisl(ilayer)) ) then - ! solution_found = .false. - ! error_code = 4 - ! error_arr(:) = th_node(:) - ! exit - !end if - - ! Check if any psi values are > 0 - !if(any(psi_node(:) > nearzero)) then - ! solution_found = .false. - ! error_code = 4 - ! error_arr(:) = psi_node(:) - ! exit - !end if - ! Accumulate the water balance error of the layer over the sub-steps ! for diagnostic purposes ! [kg/m2] @@ -3811,11 +3706,6 @@ subroutine ImTaylorSolve1D(site_hydr,bc_in,cohort,cohort_hydr,dtime,q_top, & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & cohort_hydr%l_aroot_layer(ilayer) * & cohort%n / site_hydr%l_aroot_layer(ilayer) - - if(j==1) then - print*,'did not exit 2' - stop - end if enddo !soil layer (jj -> ilayer) @@ -3825,7 +3715,7 @@ end subroutine ImTaylorSolve1D ! ===================================================================================== - subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & + subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & rootfr_scaler, aroot_frac_plant, err_code, err_arr) @@ -3835,7 +3725,6 @@ subroutine Report1DError(cohort, site_hydr, bc_in, ilayer, z_node, v_node, & ! Arguments (IN) type(ed_cohort_type),intent(in),target :: cohort type(ed_site_hydr_type),intent(in), target :: site_hydr - type(bc_in_type), intent(in) :: bc_in ! FATES boundary conditions integer, intent(in) :: ilayer ! soil layer index of interest real(r8), intent(in) :: z_node(:) ! elevation of nodes real(r8), intent(in) :: v_node(:) ! volume of nodes @@ -4326,41 +4215,36 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s integer :: nshells ! We don't use the global because of unit testing !----------------------------------------------------------------------- - if(l_aroot 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if + nshells = size(r_out_shell,dim=1) + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 enddo end if + + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + + do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo + + ! update volumes + do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + return end subroutine shellGeom ! ===================================================================================== @@ -4500,7 +4384,7 @@ end subroutine Hydraulics_Tridiagonal ! ===================================================================================== - subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & + subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & tmx,qtop, & sapflow,rootuptake,wb_err_plant , dwat_plant, & dth_layershell_site) @@ -4541,7 +4425,6 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure type(ed_cohort_hydr_type), target :: cohort_hydr type(ed_cohort_type) , intent(inout), target :: cohort - type(bc_in_type),intent(in) :: bc_in real(r8),intent(in) :: tmx ! time interval to integrate over [s] real(r8),intent(in) :: qtop real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] @@ -4712,7 +4595,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & ! from the cohort structures, into the complete node vector i = n_hypool_ag + n_hypool_troot - do j = 1,site_hydr%nlevsoi_hyd + do j = 1,site_hydr%nlevrhiz ! Calculate the fraction of the soil layer ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment @@ -4723,12 +4606,12 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & do k = 1, n_hypool_aroot + nshell i = i + 1 if (k==1) then - z_node(i) = -bc_in%z_sisl(j) + z_node(i) = -site_hydr%zi_rhiz(j) v_node(i) = cohort_hydr%v_aroot_layer(j) th_node_init(i) = cohort_hydr%th_aroot(j) else kshell = k-1 - z_node(i) = -bc_in%z_sisl(j) + z_node(i) = -site_hydr%zi_rhiz(j) ! The volume of the Rhizosphere for a single plant v_node(i) = site_hydr%v_shell(j,kshell)*aroot_frac_plant th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) @@ -5158,7 +5041,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & sapflow = sapflow + q_flux(n_hypool_ag)*dtime - do j = 1,site_hydr%nlevsoi_hyd + do j = 1,site_hydr%nlevrhiz ! Connection betwen the 1st rhizosphere and absorbing roots icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 rootuptake = rootuptake + q_flux(icnx_ar)*dtime @@ -5187,7 +5070,7 @@ subroutine MatSolve2D(site_hydr,bc_in,cohort,cohort_hydr, & dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o inode = n_hypool_ag+n_hypool_troot - do j = 1,site_hydr%nlevsoi_hyd + do j = 1,site_hydr%nlevrhiz do k = 1, nshell+1 inode = inode + 1 if(k==1) then @@ -5268,7 +5151,7 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_u ! Path is between the transporting root and the absorbing roots inode = n_hypool_ag - do j = 1,site_hydr%nlevsoi_hyd + do j = 1,site_hydr%nlevrhiz aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) @@ -5464,7 +5347,7 @@ end subroutine InitHydroGlobals !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) !!end if !!end do - !!do j=1,site_hydr%nlevsoi_hyd + !!do j=1,site_hydr%nlevrhiz !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 6ebeb04fe6..3a436148d9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -426,7 +426,7 @@ module FatesHistoryInterfaceMod integer :: ih_tran_scpf ! integer :: ih_rootuptake_scpf ! integer :: ih_rootuptake_sl - integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension +! integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension integer :: ih_sapflow_scpf integer :: ih_iterh1_scpf integer :: ih_iterh2_scpf @@ -3247,7 +3247,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) integer :: io_pa1 ! The first patch index in the IO array for each site integer :: ft ! functional type index integer :: scpf - integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array +! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8), parameter :: tiny = 1.e-5_r8 ! some small number @@ -3277,7 +3277,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & ! hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & ! hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & - hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & +! hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & @@ -3446,13 +3446,15 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) cpatch => cpatch%younger end do !patch loop - io_shsl = 0 - do j=1,sites(s)%si_hydr%nlevsoi_hyd - do k=1, nshell - io_shsl = io_shsl + 1 - hio_h2osoi_shsl(io_si,io_shsl) = sites(s)%si_hydr%h2osoi_liqvol_shell(j,k) - end do - end do + ! THE "SHSL" ARRAY CAN VERY EASILY BE LARGER THAN THE SCAGPFT ARRAY + ! WHICH IT WAS USING AS A SURROGATE, DISABLING (RGK 02-2020) +! io_shsl = 0 +! do j=1,sites(s)%si_hydr%nlevrhiz +! do k=1, nshell +! io_shsl = io_shsl + 1 +! hio_h2osoi_shsl(io_si,io_shsl) = sites(s)%si_hydr%h2osoi_liqvol_shell(j,k) +! end do +! end do if(hlm_use_ed_st3.eq.ifalse) then do scpf=1,nlevsclass*numpft @@ -5041,10 +5043,10 @@ subroutine define_history_vars(this, initialize_variables) ! avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, & ! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) - call this%set_history_var(vname='FATES_H2OSOI_COL_SHSL', units='m3/m3', & - long='volumetric soil moisture by layer and shell', use_default='inactive', & - avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2osoi_si_scagpft ) +! call this%set_history_var(vname='FATES_H2OSOI_COL_SHSL', units='m3/m3', & +! long='volumetric soil moisture by layer and shell', use_default='inactive', & +! avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2osoi_si_scagpft ) call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & long='individual sap flow rate', use_default='inactive', & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 1aa0ed6737..d693da4cea 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -61,8 +61,11 @@ module FatesHydraulicsMemMod ! Mean fine root radius expected in the bulk soil real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 - + ! Should we ignore the first soil layer and have root layers start on the second? + logical, parameter, public :: ignore_layer1=.true. + + ! Derived parameters ! ---------------------------------------------------------------------------------------------- @@ -74,12 +77,11 @@ module FatesHydraulicsMemMod type, public :: ed_site_hydr_type ! Plant Hydraulics - - integer :: nlevsoi_hyd ! The number of soil hydraulic layers - ! the host model may offer different number of - ! layers for every site, and hydraulics - ! may or may not cross that with a simple or - ! non-simple layering + integer :: i_rhiz_t ! Soil layer index of top rhizosphere + integer :: i_rhiz_b ! Soil layer index of bottom rhizospher layer + integer :: nlevrhiz ! Number of rhizosphere levels (vertical layers) + real(r8), allocatable :: zi_rhiz(:) ! Depth of the bottom edge of each rhizosphere level [m] + real(r8), allocatable :: dz_rhiz(:) ! Width of each rhizosphere level [m] real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m3) over the ! entire site (ha), absolute quantity @@ -333,24 +335,23 @@ module FatesHydraulicsMemMod contains - subroutine AllocateHydrCohortArrays(this,nlevsoil_hydr) + subroutine AllocateHydrCohortArrays(this,nlevrhiz) ! Arguments class(ed_cohort_hydr_type),intent(inout) :: this - integer, intent(in) :: nlevsoil_hydr - - allocate(this%kmax_troot_lower(1:nlevsoil_hydr)) - allocate(this%kmax_aroot_upper(1:nlevsoil_hydr)) - allocate(this%kmax_aroot_lower(1:nlevsoil_hydr)) - allocate(this%kmax_aroot_radial_in(1:nlevsoil_hydr)) - allocate(this%kmax_aroot_radial_out(1:nlevsoil_hydr)) - allocate(this%v_aroot_layer_init(1:nlevsoil_hydr)) - allocate(this%v_aroot_layer(1:nlevsoil_hydr)) - allocate(this%l_aroot_layer(1:nlevsoil_hydr)) - allocate(this%th_aroot(1:nlevsoil_hydr)) - allocate(this%psi_aroot(1:nlevsoil_hydr)) - allocate(this%ftc_aroot(1:nlevsoil_hydr)) -! allocate(this%rootuptake(1:nlevsoil_hydr)) + integer, intent(in) :: nlevrhiz + + allocate(this%kmax_troot_lower(1:nlevrhiz)) + allocate(this%kmax_aroot_upper(1:nlevrhiz)) + allocate(this%kmax_aroot_lower(1:nlevrhiz)) + allocate(this%kmax_aroot_radial_in(1:nlevrhiz)) + allocate(this%kmax_aroot_radial_out(1:nlevrhiz)) + allocate(this%v_aroot_layer_init(1:nlevrhiz)) + allocate(this%v_aroot_layer(1:nlevrhiz)) + allocate(this%l_aroot_layer(1:nlevrhiz)) + allocate(this%th_aroot(1:nlevrhiz)) + allocate(this%psi_aroot(1:nlevrhiz)) + allocate(this%ftc_aroot(1:nlevrhiz)) return end subroutine AllocateHydrCohortArrays @@ -372,7 +373,6 @@ subroutine DeallocateHydrCohortArrays(this) deallocate(this%th_aroot) deallocate(this%psi_aroot) deallocate(this%ftc_aroot) -! deallocate(this%rootuptake) return end subroutine DeallocateHydrCohortArrays @@ -385,22 +385,25 @@ subroutine InitHydrSite(this,numpft,numlevsclass) class(ed_site_hydr_type),intent(inout) :: this integer,intent(in) :: numpft integer,intent(in) :: numlevsclass - associate( nlevsoil_hydr => this%nlevsoi_hyd ) - - allocate(this%v_shell(1:nlevsoil_hydr,1:nshell)) ; this%v_shell = nan - allocate(this%v_shell_init(1:nlevsoil_hydr,1:nshell)) ; this%v_shell_init = nan - allocate(this%r_node_shell(1:nlevsoil_hydr,1:nshell)) ; this%r_node_shell = nan - allocate(this%r_node_shell_init(1:nlevsoil_hydr,1:nshell)); this%r_node_shell_init = nan - allocate(this%r_out_shell(1:nlevsoil_hydr,1:nshell)) ; this%r_out_shell = nan - allocate(this%l_aroot_layer(1:nlevsoil_hydr)) ; this%l_aroot_layer = nan - allocate(this%l_aroot_layer_init(1:nlevsoil_hydr)) ; this%l_aroot_layer_init = nan - allocate(this%kmax_upper_shell(1:nlevsoil_hydr,1:nshell)); this%kmax_upper_shell = nan - allocate(this%kmax_lower_shell(1:nlevsoil_hydr,1:nshell)); this%kmax_lower_shell = nan - allocate(this%supsub_flag(1:nlevsoil_hydr)) ; this%supsub_flag = -999 - allocate(this%h2osoi_liqvol_shell(1:nlevsoil_hydr,1:nshell)) ; this%h2osoi_liqvol_shell = nan - allocate(this%h2osoi_liq_prev(1:nlevsoil_hydr)) ; this%h2osoi_liq_prev = nan - allocate(this%rs1(1:nlevsoil_hydr)); this%rs1(:) = fine_root_radius_const - allocate(this%recruit_w_uptake(1:nlevsoil_hydr)); this%recruit_w_uptake = nan + + associate(nlevrhiz => this%nlevrhiz) + + allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan + allocate(this%dz_rhiz(1:nlevrhiz)); this%dz_rhiz(:) = nan + allocate(this%v_shell(1:nlevrhiz,1:nshell)) ; this%v_shell = nan + allocate(this%v_shell_init(1:nlevrhiz,1:nshell)) ; this%v_shell_init = nan + allocate(this%r_node_shell(1:nlevrhiz,1:nshell)) ; this%r_node_shell = nan + allocate(this%r_node_shell_init(1:nlevrhiz,1:nshell)); this%r_node_shell_init = nan + allocate(this%r_out_shell(1:nlevrhiz,1:nshell)) ; this%r_out_shell = nan + allocate(this%l_aroot_layer(1:nlevrhiz)) ; this%l_aroot_layer = nan + allocate(this%l_aroot_layer_init(1:nlevrhiz)) ; this%l_aroot_layer_init = nan + allocate(this%kmax_upper_shell(1:nlevrhiz,1:nshell)); this%kmax_upper_shell = nan + allocate(this%kmax_lower_shell(1:nlevrhiz,1:nshell)); this%kmax_lower_shell = nan + allocate(this%supsub_flag(1:nlevrhiz)) ; this%supsub_flag = -999 + allocate(this%h2osoi_liqvol_shell(1:nlevrhiz,1:nshell)) ; this%h2osoi_liqvol_shell = nan + allocate(this%h2osoi_liq_prev(1:nlevrhiz)) ; this%h2osoi_liq_prev = nan + allocate(this%rs1(1:nlevrhiz)); this%rs1(:) = fine_root_radius_const + allocate(this%recruit_w_uptake(1:nlevrhiz)); this%recruit_w_uptake = nan allocate(this%sapflow(1:numlevsclass,1:numpft)); this%sapflow = nan this%errh2o_hyd = nan @@ -411,64 +414,64 @@ subroutine InitHydrSite(this,numpft,numlevsclass) this%h2oveg_growturn_err = 0.0_r8 this%h2oveg_pheno_err = 0.0_r8 this%h2oveg_hydro_err = 0.0_r8 - + ! We have separate water transfer functions and parameters ! for each soil layer, and each plant compartment type - allocate(this%wrf_soil(1:nlevsoil_hydr)) - allocate(this%wkf_soil(1:nlevsoil_hydr)) - + allocate(this%wrf_soil(1:nlevrhiz)) + allocate(this%wkf_soil(1:nlevrhiz)) + if(use_2d_hydrosolve) then - - this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & - + (n_hypool_aroot + nshell) * nlevsoil_hydr - - this%num_nodes = n_hypool_leaf + n_hypool_stem + n_hypool_troot & - + (n_hypool_aroot + nshell) * nlevsoil_hydr - - ! These are only in the newton-matrix solve - allocate(this%conn_up(this%num_connections)) - allocate(this%conn_dn(this%num_connections)) - allocate(this%residual(this%num_nodes)) - allocate(this%ajac(this%num_nodes,this%num_nodes)) - allocate(this%th_node_init(this%num_nodes)) - allocate(this%th_node(this%num_nodes)) - allocate(this%dth_node(this%num_nodes)) - allocate(this%h_node(this%num_nodes)) - allocate(this%v_node(this%num_nodes)) - allocate(this%z_node(this%num_nodes)) - allocate(this%psi_node(this%num_nodes)) - allocate(this%q_flux(this%num_connections)) - allocate(this%dftc_dpsi_node(this%num_nodes)) - allocate(this%ftc_node(this%num_nodes)) - allocate(this%pm_node(this%num_nodes)) - allocate(this%ipiv(this%num_nodes)) - allocate(this%node_layer(this%num_nodes)) - - allocate(this%kmax_up(this%num_connections)) - allocate(this%kmax_dn(this%num_connections)) - - else - - this%num_connections = n_hypool_leaf + n_hypool_stem + & - n_hypool_troot + n_hypool_aroot + nshell -1 - - this%num_nodes = n_hypool_leaf + n_hypool_stem + & + + this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + + (n_hypool_aroot + nshell) * nlevrhiz + + this%num_nodes = n_hypool_leaf + n_hypool_stem + n_hypool_troot & + + (n_hypool_aroot + nshell) * nlevrhiz + + ! These are only in the newton-matrix solve + allocate(this%conn_up(this%num_connections)) + allocate(this%conn_dn(this%num_connections)) + allocate(this%residual(this%num_nodes)) + allocate(this%ajac(this%num_nodes,this%num_nodes)) + allocate(this%th_node_init(this%num_nodes)) + allocate(this%th_node(this%num_nodes)) + allocate(this%dth_node(this%num_nodes)) + allocate(this%h_node(this%num_nodes)) + allocate(this%v_node(this%num_nodes)) + allocate(this%z_node(this%num_nodes)) + allocate(this%psi_node(this%num_nodes)) + allocate(this%q_flux(this%num_connections)) + allocate(this%dftc_dpsi_node(this%num_nodes)) + allocate(this%ftc_node(this%num_nodes)) + allocate(this%pm_node(this%num_nodes)) + allocate(this%ipiv(this%num_nodes)) + allocate(this%node_layer(this%num_nodes)) + + allocate(this%kmax_up(this%num_connections)) + allocate(this%kmax_dn(this%num_connections)) + + else + + this%num_connections = n_hypool_leaf + n_hypool_stem + & + n_hypool_troot + n_hypool_aroot + nshell -1 + + this%num_nodes = n_hypool_leaf + n_hypool_stem + & n_hypool_troot + n_hypool_aroot + nshell - - allocate(this%conn_up(this%num_connections)) - allocate(this%conn_dn(this%num_connections)) - allocate(this%pm_node(this%num_nodes)) - - - end if - - call this%SetConnections() - + + allocate(this%conn_up(this%num_connections)) + allocate(this%conn_dn(this%num_connections)) + allocate(this%pm_node(this%num_nodes)) + + + end if + + call this%SetConnections() + end associate return - end subroutine InitHydrSite + end subroutine InitHydrSite ! =================================================================================== @@ -534,7 +537,7 @@ subroutine SetConnections(this) this%node_layer(1:n_hypool_ag) = 0 this%node_layer(num_nds) = 1 - do j = 1,this%nlevsoi_hyd + do j = 1,this%nlevrhiz do k = 1, n_hypool_aroot + nshell num_nds = num_nds + 1 num_cnxs = num_cnxs + 1 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 90c08fead8..3bd22acf13 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -439,9 +439,11 @@ module FatesInterfaceMod ! Site level filter for uptake response functions logical :: filter_btran + + ! ALL HYDRO DATA STRUCTURES SHOULD NOW BE ALLOCATED ON RHIZOSPHERE LEVELS + ! Plant-Hydro ! --------------------------------------------------------------------------------- - real(r8),allocatable :: qflx_transp_pa(:) ! Transpiration flux as dictated by the HLM's ! canopy solver. [mm H2O/s] [+ into root] @@ -557,6 +559,8 @@ module FatesInterfaceMod ! FATES Hydraulics + + real(r8) :: plant_stored_h2o_si ! stored water in LIVE+DEAD vegetation (kg/m2 H2O) ! Assuming density of 1Mg/m3 ~= mm/m2 H2O ! This must be set and transfered prior to clm_drv() @@ -669,7 +673,6 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in) type(bc_in_type), intent(inout) :: bc_in integer,intent(in) :: nlevsoil_in integer,intent(in) :: nlevdecomp_in - ! Allocate input boundaries @@ -770,10 +773,11 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then - + allocate(bc_in%qflx_transp_pa(maxPatchesPerSite)) allocate(bc_in%swrad_net_pa(maxPatchesPerSite)) allocate(bc_in%lwrad_net_pa(maxPatchesPerSite)) + allocate(bc_in%watsat_sisl(nlevsoil_in)) allocate(bc_in%watres_sisl(nlevsoil_in)) allocate(bc_in%sucsat_sisl(nlevsoil_in)) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index dd4b41fbdf..371380ebcf 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1652,7 +1652,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) - call this%SetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevsoi_hyd, & + call this%SetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) = ccohort%co_hydr%th_troot @@ -1894,7 +1894,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) this%rvars(ir_hydro_hydro_err_si)%r81d(io_idx_si) = sites(s)%si_hydr%h2oveg_hydro_err ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell - do i = 1, sites(s)%si_hydr%nlevsoi_hyd + do i = 1, sites(s)%si_hydr%nlevrhiz ! Loop shells do k = 1, nshell this%rvars(ir_hydro_liqvol_shell_si)%r81d(io_idx_si_lyr_shell) = & @@ -2407,7 +2407,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) - call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevsoi_hyd, & + call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) @@ -2562,7 +2562,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%si_hydr%h2oveg_hydro_err = this%rvars(ir_hydro_hydro_err_si)%r81d(io_idx_si) ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell - do i = 1, sites(s)%si_hydr%nlevsoi_hyd + do i = 1, sites(s)%si_hydr%nlevrhiz ! Loop shells do k = 1, nshell sites(s)%si_hydr%h2osoi_liqvol_shell(i,k) = & From 74aa9fcd06d362d71a79944e2451a393d440f6fc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 18 Feb 2020 11:46:59 -0800 Subject: [PATCH 066/114] Removing deprecated hydo code --- biogeophys/FatesHydroUnitFunctionsMod.F90_old | 1932 ----------------- 1 file changed, 1932 deletions(-) delete mode 100644 biogeophys/FatesHydroUnitFunctionsMod.F90_old diff --git a/biogeophys/FatesHydroUnitFunctionsMod.F90_old b/biogeophys/FatesHydroUnitFunctionsMod.F90_old deleted file mode 100644 index 1a19b9eb6a..0000000000 --- a/biogeophys/FatesHydroUnitFunctionsMod.F90_old +++ /dev/null @@ -1,1932 +0,0 @@ -module FatesHydroUnitFunctionsMod - - ! This module contains hydraulics functions that are readily broken down into - ! unit tests. These are functions that mostly operate on primitive - ! arguments, are smaller in scope, and are allowed to access the - ! parameter constants EDPftvarcon_inst and params - - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : fates_unset_r8 - use FatesConstantsMod, only : pa_per_mpa - use FatesConstantsMod, only : mpa_per_pa - use FatesConstantsMod, only : mm_per_m - use FatesConstantsMod, only : m_per_mm - use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water - use FatesConstantsMod, only : grav_earth - use FatesConstantsMod, only : nearzero - use FatesConstantsMod, only : pi_const - use - use EDPftvarcon, only : pft_p => EDPftvarcon_inst - use EDParamsMod, only : hydr_psi0 - use EDParamsMod, only : hydr_psicap - use FatesGlobals, only : fates_log - use FatesGlobals, only : endrun => fates_endrun - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - logical, parameter :: debug=.true. - character(len=*), parameter, private :: sourcefile = __FILE__ - - ! Currently testing two different ways to represent rhizosphere shell - ! volumes. The old way used a "representative" shell volume, the - ! new way is an absolute volume, in total cubic meters over the - ! whole hectare. - - integer, parameter :: bcvol = 1 - integer, parameter :: rkvol = 2 - integer, parameter :: voltype = rkvol - - ! We have an array of options for different PV curves. - ! Note that we can also use a hybrid of PV curves - ! for soil, and those targetted for plants, which - ! factor in elastic ranges, capilary ranges and cavitation - ! ranges in plants (eccp). *Note, we have found that - ! mixing different PV methods, while scientifically interesting - ! *may* lead to strange and unstable behavior. - - - - logical, public, parameter :: allow_unconstrained_theta = .true. - - real(r8), parameter :: min_rhiz_psi = -20._r8 ! Minimum allowable rhizosphere - ! matric potential [MPa] - - real(r8), parameter :: max_dpsidth = 2000._r8 ! Some of these functions have - ! very stiff derivatives, so we cap - ! the psi to theta pedotransfer - ! functions so they can not - ! exceed this value on the residual - ! side of the theta. Ultimately - ! this is used to calculate a - ! lower theta bound - ! [MPa/ m3/m3] - - ! Parameter to enable some positive pressure in soils, just to avoid super-saturation - ! which will cause problems for a host model. These parameters are roughly - ! tuned to get 0.5 MPa positive pressure at exactly saturation, starting - ! a parabolic curve from the offset. - - real(r8), parameter :: ss_wcoff = 0.05 ! WC offset from saturation, from which - ! we start to adding some positive pressure - ! to avoid super-saturation - real(r8), parameter :: ss_a = 15.0_r8 ! slope parameter for positive pressure function - real(r8), parameter :: ss_b = 2.0_r8 ! slope parameter for positive pressure function - - ! P-V curve: total RWC @ which elastic drainage begins [-] - real(r8), allocatable :: rwcft(:) ! = (/1.0_r8,0.958_r8,0.958_r8,0.958_r8/) - - ! P-V curve: total RWC @ which capillary reserves exhausted - real(r8), allocatable :: rwccap(:) ! = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) - - ! P-V curve: slope of capillary region of curve - real(r8), allocatable :: cap_slp(:) - - ! P-V curve: intercept of capillary region of curve - real(r8), allocatable :: cap_int(:) - - ! P-V curve: correction for nonzero psi0x - real(r8), allocatable :: cap_corr(:) - - - public :: Hydraulics_Tridiagonal - public :: flc_gs_from_psi - public :: dflcgsdpsi_from_psi - public :: flc_from_psi - public :: dflcdpsi_from_psi - public :: th_from_psi - public :: psi_from_th - public :: dpsidth_from_th - - public :: bisect_rootfr - public :: zeng2001_crootfr - public :: shellGeom - public :: xylemtaper - public :: InitAllocatePlantMedia - public :: SetPlantMediaParam - public :: swcCampbell_satfrac_from_psi - public :: swcCampbell_th_from_satfrac - public :: swcCampbell_psi_from_th - - - ! This is the base type for all pedotransfer functions (PTFs) - ! Currently, we are mostly using water release curves, we may - ! add conductivity calculations. - ! Note, that the standard convention for allocating parameters - ! is to assign soil layers as negative indices, and - ! special porous media (i.e. aroot, troot, stem and leaves) - - - - - - -contains - - - - - - - - - - - ! ===================================================================================== - - subroutine InitAllocatePlantMedia(n_plant_media) - - ! We only allocate for plant porous media, we do - ! not use these arrays to inform on soil relationships - integer,intent(in) :: n_plant_media - - allocate(rwcft(n_plant_media)) - allocate(rwccap(n_plant_media)) - allocate(cap_slp(n_plant_media)) - allocate(cap_int(n_plant_media)) - allocate(cap_corr(n_plant_media)) - - rwcft(:) = fates_unset_r8 - rwccap(:) = fates_unset_r8 - cap_slp(:) = fates_unset_r8 - cap_int(:) = fates_unset_r8 - cap_corr(:) = fates_unset_r8 - - return - end subroutine InitAllocatePlantMedia - - ! ===================================================================================== - - subroutine SetPlantMediaParam(pm,rwcft_in,rwccap_in) - - ! To avoid complications that would arise from linking this - ! module with the FatesHydraulicsMemMod.F90 during unit tests, we - ! store some of these arrays that are indexed by "porous_media" - ! as globals in this module. - - integer,intent(in) :: pm ! porous media index - real(r8),intent(in) :: rwcft_in ! rwcft for this pm - real(r8),intent(in) :: rwccap_in ! rwcap for this pm - - rwcft(pm) = rwcft_in - rwccap(pm) = rwccap_in - - if (pm.eq.1) then ! Leaf tissue - cap_slp(pm) = 0.0_r8 - cap_int(pm) = 0.0_r8 - cap_corr(pm) = 1.0_r8 - else ! Non leaf tissues - cap_slp(pm) = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int(pm) = -cap_slp(pm) + hydr_psi0 - cap_corr(pm) = -cap_int(pm)/cap_slp(pm) - end if - - return - end subroutine SetPlantMediaParam - - - - !===============================================================================! - - function flc_gs_from_psi( lwp, ft ) result( btran ) - - ! - ! !DESCRIPTION: Calculates fractional loss of conductance - ! across the stomata (gs). - - ! - ! !ARGUMENTS - real(r8) , intent(in) :: lwp !leaf water potential (MPa) - integer , intent(in) :: ft - real(r8) :: btran - - btran = & - (1._r8 + & - (lwp/pft_p%hydr_p50_gs(ft))**pft_p%hydr_avuln_gs(ft))**(-1._r8) - - end function flc_gs_from_psi - - !===============================================================================! - - function dflcgsdpsi_from_psi(lwp, ft) result (dflcgsdpsi) - - ! Calculate the derivative of change in fractional loss of conductivity - ! WRT matric potential. - - ! !ARGUMENTS - real(r8), intent(in) :: lwp ! leaf water potential (MPa) - integer , intent(in) :: ft ! leaf pft - - real(r8) :: dflcgsdpsi ! fractional loss of conductivity [-] - - - associate(avuln_gs => pft_p%hydr_avuln_gs, & ! Stomatal PLC curve: shape parameter [-] - p50_gs => pft_p%hydr_p50_gs) ! Stomatal PLC curve: water potential - ! at 50% loss of gs,max [Pa] - - - dflcgsdpsi = -1._r8 * (1._r8 + (lwp/p50_gs(ft))**avuln_gs(ft))**(-2._r8) * & - avuln_gs(ft)/p50_gs(ft)*(lwp/p50_gs(ft))**(avuln_gs(ft)-1._r8) - - end associate - - end function dflcgsdpsi_from_psi - - !===============================================================================! - - function flc_from_psi(ft, pm, th_in, psi_in, suc_sat, bsw) result(flc_node) - - ! !DESCRIPTION: calls necessary routines (plant vs. soil) for converting - ! plant tissue or soil water potentials to a fractional loss of conductivity - - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: th_in ! water content [m3/m3] - real(r8) , intent(in) :: psi_in ! water potential [MPa] - real(r8), optional,intent(in) :: suc_sat ! minimum soil suction [mm] - real(r8), optional,intent(in) :: bsw ! col Clapp and Hornberger "b" - - real(r8) :: psi_resid ! matric potential @ residual WC [MPa] - real(r8) :: flc_node ! frac loss of conductivity [-] - - associate(& - avuln => pft_p%hydr_avuln_node , & ! PLC curve: vulnerability curve shape parameter [-] - p50 => pft_p%hydr_p50_node & ! PLC curve: water potential at 50% loss of conductivity [Pa] - ) - - if(pm <= 4) then - if(allow_unconstrained_theta) then - if(th_in>pft_p%hydr_thetas_node(ft,pm)) then - psi_resid = psi_from_th(ft,pm,pft_p%hydr_thetas_node(ft,pm)) - flc_node = 1._r8/(1._r8 + (psi_resid/p50(ft,pm))**avuln(ft,pm)) ! should be 1 - elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then -! ! The derivative at the hard-cap is 0 -! dpsidth = 0._r8 -! else - if(th_in(th_sat-ss_wcoff)) then - psi_node = suc_sat_mpa + (ss_a*(th_in-(th_sat-ss_wcoff)))**ss_b - elseif(th_inpft_p%hydr_thetas_node(ft,pm)) then -! ! The derivative at the hard-cap is 0 -! dpsidth = 0._r8 -! else - if(th_in(th_sat-ss_wcoff)) then - call swcCampbell_dpsidth_from_th(th_in, & - th_sat, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - dpsidth) - dpsidth = dpsidth + ss_b*(ss_a*(th_in-(th_sat-ss_wcoff)))**(ss_b-1._r8)*ss_a - elseif(th_in<=th_cap) then - dpsidth = max_dpsidth - else - call swcCampbell_dpsidth_from_th(th_in, & - th_sat, & - -1._r8*suc_sat*denh2o*grav_earth*m_per_mm*mpa_per_pa, & - bsw, & - dpsidth) - end if - - case default - write(fates_log(),*) 'ERROR: invalid soil water characteristic function specified, iswc = '//char(iswc) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end function dpsidth_from_th - - ! ===================================================================================== - - function swcCampbell_th_from_dpsidth(th_sat,psi_sat,bsw) result(th) - - ! ----------------------------------------------------------------------------------- - ! This function is used to determine the water content where we start capping the - ! derivative. The whole purpose here is to enable pedotransfer functions that - ! are slightly more well behaved. If this value is smaller than the residual - ! water content of the media, then we will be extrapolating from the residual. - ! ----------------------------------------------------------------------------------- - - real(r8), intent(in) :: th_sat - real(r8), intent(in) :: psi_sat ! minimum soil suction [mm] - real(r8), intent(in) :: bsw ! col Clapp and Hornberger "b" - real(r8) :: th ! theta matching this dpsidth - - ! Invert: - ! dpsidth = -B * psisat * (1._r8/watsat) * (th/watsat)**(-B-1.0) - ! - ! - ! watsat*(max_dpsidth*watsat/(-B*psisat))**(1/(-B-1.0)) = th - - th = th_sat*(th_sat*max_dpsidth/(-bsw*psi_sat))**(1._r8/(-bsw-1._r8)) - - return - end function swcCampbell_th_from_dpsidth - - ! ==================================================================================== - - function PsiFromThECCP(ft,pm,th_in) result (psi_node) - - integer :: ft - integer :: pm - real(r8) :: th_in - - real(r8) :: psi_node - - if(th_in<(pft_p%hydr_resid_node(ft,pm)+nearzero)) then - ! Perform extrapolation from residual WC - call tq2(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), psi_resid) - call dtq2dth(ft, pm, (pft_p%hydr_resid_node(ft,pm)+nearzero)*cap_corr(pm), dpsidth_resid) - psi_node = psi_resid + (th_in-pft_p%hydr_resid_node(ft,pm)) * dpsidth_resid - else - call tq2(ft, pm, th_in*cap_corr(pm), psi_node) - end if - - - return - end subroutine PsiFromThECCP - - !===============================================================================! - - subroutine tq2(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq2 ! returned y (psi) value from bq2() - real(r8) :: y_cq2 ! returned y (psi) value from cq2() - real(r8) :: beta2=0.99_r8 ! smoothing factor - !---------------------------------------------------------------------- - - call bq2(ft, pm, x, y_bq2) - call cq2(ft, pm, x, y_cq2) - y = (-y_bq2 + sqrt(y_bq2*y_bq2 - 4._r8*beta2*y_cq2))/(2*beta2) - - end subroutine tq2 - - !===============================================================================! - - subroutine dtq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: smoothing function for elastic-to-cavitation region of the - ! plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq2 ! returned y (psi) value from bq2() - real(r8) :: y_cq2 ! returned y (psi) value from cq2() - real(r8) :: dydth_bq2 ! returned derivative from dbq2dth() - real(r8) :: dydth_cq2 ! returned derivative from dcq2dth() - real(r8) :: beta2=0.99_r8 ! smoothing factor - !---------------------------------------------------------------------- - - call bq2(ft, pm, x, y_bq2) - call cq2(ft, pm, x, y_cq2) - call dbq2dth(ft, pm, x, dydth_bq2) - call dcq2dth(ft, pm, x, dydth_cq2) - y = 1._r8/(2._r8*beta2)*(-dydth_bq2 + 0.5_r8*((y_bq2*y_bq2 - 4._r8*beta2*y_cq2)**(-0.5_r8)) * & - (2._r8*y_bq2*dydth_bq2 - 4._r8*beta2*dydth_cq2)) - - end subroutine dtq2dth - - !===============================================================================! - - subroutine bq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = -1._r8*(y_tq1 + y_cavitation) - - end subroutine bq2 - - !===============================================================================! - - subroutine dbq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = -1._r8*(dydth_tq1 + dcavdth) - - end subroutine dbq2dth - - !===============================================================================! - - subroutine cq2(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for elastic-to-cavitation region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - y = y_tq1*y_cavitation - - end subroutine cq2 - - !===============================================================================! - - subroutine dcq2dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq2() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_tq1 ! returned y (psi) value from tq1() - real(r8) :: y_cavitation ! returned y (psi) value from cavitationPV() - real(r8) :: dydth_tq1 ! returned derivative from dtq1dth() - real(r8) :: dcavdth ! returned derivative from dcavitationdth() - !---------------------------------------------------------------------- - - call tq1(ft, pm, x, y_tq1) - call cavitationPV(ft, pm, x, y_cavitation) - call dtq1dth(ft, pm, x, dydth_tq1) - call dcavitationPVdth(ft, pm, x, dcavdth) - y = y_tq1*dcavdth + dydth_tq1*y_cavitation - - end subroutine dcq2dth - - !===============================================================================! - - subroutine tq1(ft, pm, x, y) - ! - ! !DESCRIPTION: either calls the elastic region of the PV curve (leaves) or - ! does a smoothing function for capillary-to-elastic region of the plant PV - ! curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call elasticPV(ft, pm, x, y_elastic) - y = y_elastic - else if(pm <= 4) then ! sapwood has a capillary region - call bq1(ft, pm, x, y_bq1) - call cq1(ft, pm, x, y_cq1) - y = (-y_bq1 - sqrt(y_bq1*y_bq1 - 4._r8*beta1*y_cq1))/(2*beta1) - end if !porous media - - end subroutine tq1 - - !===============================================================================! - - subroutine dtq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of tq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_bq1 ! returned y (psi) value from bq1() - real(r8) :: y_cq1 ! returned y (psi) value from cq1() - real(r8) :: dydth_bq1 ! returned derivative from dbq1dth() - real(r8) :: dydth_cq1 ! returned derivative from dcq1dth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - real(r8) :: beta1=0.80_r8 ! smoothing factor - !---------------------------------------------------------------------- - - if(pm == 1) then ! leaves have no capillary region in their PV curves - call delasticPVdth(ft, pm, x, delasticdth) - y = delasticdth - else if(pm <= 4) then ! sapwood has a capillary region - call bq1(ft, pm, x, y_bq1) - call cq1(ft, pm, x, y_cq1) - call dbq1dth(ft, pm, x, dydth_bq1) - call dcq1dth(ft, pm, x, dydth_cq1) - y = 1._r8/(2._r8*beta1)*(-dydth_bq1 - 0.5_r8*((y_bq1*y_bq1 - 4._r8*beta1*y_cq1)**(-0.5_r8)) * & - (2._r8*y_bq1*dydth_bq1 - 4._r8*beta1*dydth_cq1)) - end if - - end subroutine dtq1dth - - !===============================================================================! - - subroutine bq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = -1._r8*(y_capillary + y_elastic) - - end subroutine bq1 - - !===============================================================================! - - subroutine dbq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of bq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = -1._r8*(delasticdth + dcapdth) - - end subroutine dbq1dth - - !===============================================================================! - - subroutine cq1(ft, pm, x, y) - ! - ! !DESCRIPTION: component smoothing function for capillary-to-elastic region - ! of the plant PV curve where a discontinuity exists - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - y = y_capillary*y_elastic - - end subroutine cq1 - - !===============================================================================! - - subroutine dcq1dth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cq1() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_capillary ! returned y (psi) value from capillaryPV() - real(r8) :: y_elastic ! returned y (psi) value from elasticPV() - real(r8) :: dcapdth ! returned derivative from dcapillaryPVdth() - real(r8) :: delasticdth ! returned derivative from delasticPVdth() - !---------------------------------------------------------------------- - - call capillaryPV(ft, pm, x, y_capillary) - call elasticPV(ft, pm, x, y_elastic) - call dcapillaryPVdth(ft, pm, x, dcapdth) - call delasticPVdth(ft, pm, x, delasticdth) - y = y_elastic*dcapdth + delasticdth*y_capillary - - end subroutine dcq1dth - - !===============================================================================! - - subroutine cavitationPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - !---------------------------------------------------------------------- - - call solutepsi(ft, pm, x, y_solute) - y = y_solute - - end subroutine cavitationPV - - !===============================================================================! - - subroutine dcavitationPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of cavitationPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - y = dsoldth - - end subroutine dcavitationPVdth - - !===============================================================================! - - subroutine elasticPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the elastic region of the plant PV - ! curve as the sum of both solute and elastic components. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: y_solute ! returned y (psi) value from solutepsi() - real(r8) :: y_pressure ! returned y (psi) value from pressurepsi() - !---------------------------------------------------------------------- - - call solutepsi(ft, pm, x, y_solute) - call pressurepsi(ft, pm, x, y_pressure) - y = y_solute + y_pressure - - end subroutine elasticPV - - !===============================================================================! - - subroutine delasticPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of elasticPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: dsoldth ! returned derivative from dsolutepsidth() - real(r8) :: dpressdth ! returned derivative from dpressurepsidth() - !---------------------------------------------------------------------- - - call dsolutepsidth(ft, pm, x, dsoldth) - call dpressurepsidth(ft, pm, x, dpressdth) - y = dsoldth + dpressdth - - end subroutine delasticPVdth - - !===============================================================================! - - subroutine solutepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes solute water potential (negative) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => pft_p%hydr_pinot_node, & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => pft_p%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) - - -! print*,"-----------" -! print*,ft -! print*,pm -! print*,pinot(2,1) -! print*,thetas(2,1) -! print*,rwcft(2) -! print*,resid(2,1) - - - y = pinot(ft,pm)*thetas(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - (x - thetas(ft,pm)*resid(ft,pm)) - -! print*,"y=",y - - end associate - - end subroutine solutepsi - - !===============================================================================! - - subroutine dsolutepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of solutepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => pft_p%hydr_pinot_node , & ! Input: [real(r8) (:,:) ] P-V curve: osmotic potential at full turgor [MPa] - thetas => pft_p%hydr_thetas_node , & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => pft_p%hydr_resid_node & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - ) - - y = -1._r8*thetas(ft,pm)*pinot(ft,pm)*(rwcft(pm) - resid(ft,pm)) / & - ((x - thetas(ft,pm)*resid(ft,pm))**2._r8) - - end associate - end subroutine dsolutepsidth - - !===============================================================================! - - subroutine pressurepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes pressure water potential (positive) as a function of - ! water content for the plant PV curve. - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - pinot => pft_p%hydr_pinot_node , & ! P-V curve: osmotic potential at full turgor [MPa] - thetas => pft_p%hydr_thetas_node , & ! P-V curve: saturated volumetric water content for node [m3 m-3] - resid => pft_p%hydr_resid_node , & ! P-V curve: residual fraction [-] - epsil => pft_p%hydr_epsil_node & ! P-V curve: bulk elastic modulus [MPa] - ) - - y = epsil(ft,pm) * (x - thetas(ft,pm)*rwcft(pm)) / & - (thetas(ft,pm)*(rwcft(pm)-resid(ft,pm))) - pinot(ft,pm) - - end associate - end subroutine pressurepsi - - !===============================================================================! - - subroutine dpressurepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => pft_p%hydr_thetas_node, & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - resid => pft_p%hydr_resid_node , & ! Input: [real(r8) (:,:) ] P-V curve: residual fraction [-] - epsil => pft_p%hydr_epsil_node & ! Input: [real(r8) (:,:) ] P-V curve: bulk elastic modulus [MPa] - ) - - y = epsil(ft,pm)/(thetas(ft,pm)*(rwcft(pm) - resid(ft,pm))) - - end associate - - end subroutine dpressurepsidth - - !===============================================================================! - - subroutine capillaryPV(ft, pm, x, y) - ! - ! !DESCRIPTION: computes water potential in the capillary region of the plant - ! PV curve (sapwood only) - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! water potential [MPa] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => pft_p%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) - - y = cap_int(pm) + cap_slp(pm)/thetas(ft,pm)*x - - end associate - end subroutine capillaryPV - - !===============================================================================! - - subroutine dcapillaryPVdth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of capillaryPV() wrt theta - ! - ! !USES: - ! - ! !ARGUMENTS - integer , intent(in) :: ft ! PFT index - integer , intent(in) :: pm ! porous media index - real(r8) , intent(in) :: x ! water content [m3 m-3] - real(r8) , intent(out) :: y ! derivative of water potential wrt theta [MPa m3 m-3] - ! - ! !LOCAL VARIABLES: - !---------------------------------------------------------------------- - - associate(& - thetas => pft_p%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) - - y = cap_slp(pm)/thetas(ft,pm) - - end associate - - end subroutine dcapillaryPVdth - - !===============================================================================! - - subroutine swcVG_satfrac_from_th(th, watsat, watres, satfrac) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns saturation fraction given water content, porosity, and residual water content - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(out) :: satfrac !saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - satfrac = (th - watres)/(watsat - watres) - - end subroutine swcVG_satfrac_from_th - - !===============================================================================! - - subroutine swcCampbell_satfrac_from_th(th, watsat, satfrac) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns saturation fraction given water content and porosity - ! - !USES - !ARGUMENTS: - real(r8), intent(in) :: th !soil volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(out) :: satfrac !saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - satfrac = th/watsat - - end subroutine swcCampbell_satfrac_from_th - - !===============================================================================! - - subroutine swcVG_psi_from_th(th, watsat, watres, alpha, n, m, l, psi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water potential given water content and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcVG_satfrac_from_th(th, watsat, watres, satfrac) - call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) - - end subroutine swcVG_psi_from_th - - !===============================================================================! - - subroutine swcCampbell_psi_from_th(th, watsat, psisat, B, psi) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water potential given saturation fraction, air-entry pressure and shape parameter - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) - - end subroutine swcCampbell_psi_from_th - - !===============================================================================! - - subroutine swcVG_psi_from_th(th,alpha,n,th_sat,th_res,psi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns water potential given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th ! vol wat content [m3/m3] - real(r8), intent(in) :: alpha ! inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n ! pore-size distribution index [-] - real(r8), intent(in) :: th_sat ! vwc at saturation [m3/m3] - real(r8), intent(in) :: th_res ! vwc at residual [m3/m3] - real(r8), intent(out) :: psi !soil matric potential [MPa] - - ! local variables - real(r8) :: satfrac !saturation fraction [0-1] - - !------------------------------------------------------------------------------------ - ! saturation fraction is the origial equation in vg 1980, we just - ! need to invert it: - ! satfrac = (1._r8 + (alpha*psi)**n)**(1._r8/n-1) - ! ----------------------------------------------------------------------------------- - - satfrac = (th-th_res)/(th_sat-th_res) - - psi = (1._r8/alpha)*(satfrac**(1._r8/(1._r8/n-1._r8)) - 1._r8 )**(1._r8/n) - - - end subroutine swcVG_psi_from_th - - !===============================================================================! - - subroutine swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water potential given saturation fraction, air-entry pressure and shape parameter - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: psi !soil matric potential [MPa] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - psi = psisat*(satfrac**(-B)) - - end subroutine swcCampbell_psi_from_satfrac - - - !===============================================================================! - - subroutine swcCampbell_th_from_satfrac(satfrac, watsat, th) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns water content given saturation fraction and porosity - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: satfrac !saturation fraction [0-1] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(out) :: th !soil volumetric water content [m3 m-3] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - th = satfrac*watsat - - end subroutine swcCampbell_th_from_satfrac - - !======================================================================- - subroutine swcVG_th_from_psi(psi, alpha, n, th_sat, th_res, satfrac) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns saturation fraction given water potential and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: psi ! soil matric potential [MPa] - real(r8), intent(in) :: alpha ! inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n ! pore-size distribution index [-] - real(r8), intent(in) :: m ! = 1 - 1/n_VG [-] - real(r8), intent(in) :: l ! pore tortuosity parameter [-] - real(r8), intent(in) :: th_sat ! saturation vwc [m3/m3] - real(r8), intent(in) :: th_res ! residual vwc [m3/m3] - real(r8), intent(out) :: th ! vol water content [m3/m3] - - real(r8) :: satfrac !soil saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - !satfrac = (1._r8/(1._r8 + (alpha*abs(psi))**n))**m - - ! Saturation fraction - satfrac = (1._r8 + (alpha*psi)**n)**(-1+(1._r8/n)) - - ! convert to volumetric water content - th = satfrac*(th_sat-th_res) + th_res - - - end subroutine swcVG_th_from_psi - - - - - - - - !======================================================================- - subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns saturation fraction given water potential and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: satfrac !soil saturation fraction [0-1] - ! - ! !LOCAL VARIABLES: - !------------------------------------------------------------------------------ - - satfrac = (psi/psisat)**(-1.0_r8/B) - - end subroutine swcCampbell_satfrac_from_psi - - !======================================================================- - subroutine swcVG_dpsidth_from_th(th, watsat, watres, alpha, n, m, l, dpsidth) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given water content and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: watres !volumetric residual soil water [m3 m-3] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - !------------------------------------------------------------------------------ - - call swcVG_satfrac_from_th(th, watsat, watres, satfrac) - call swcVG_dpsidth_from_satfrac(satfrac, watsat, watres, alpha, n, m, l, dpsidth) - - end subroutine swcVG_dpsidth_from_th - - !====================================================================================== - - subroutine swcCampbell_dpsidth_from_th(th, watsat, psisat, B, dpsidth) - ! - ! DESCRIPTION - ! Campbell (1974) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given water content and SWC parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: th !volumetric water content [m3 m-3] - real(r8), intent(in) :: watsat !volumetric soil water at saturation (porosity) [m3 m-3] - real(r8), intent(in) :: psisat !air entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: dpsidth !derivative of psi wrt theta [MPa/m3m-3] - ! - ! !LOCAL VARIABLES: - real(r8) :: satfrac !saturation fraction [0-1] - real(r8) :: th_min ! minimum allowable theta - !------------------------------------------------------------------------------ - -! call swcCampbell_satfrac_from_th(th, watsat, satfrac) -! call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) - -! th_min = watsat*(min_rhiz_psi/psisat)**(-1._r8/B) - - ! Constrain psi so that it can't go lower than -20MPa -! if(th1.0_r8)then - print*,psi,psisat,B,flc - stop - end if - - - end subroutine unsatkCampbell_flc_from_psi - - !======================================================================- - subroutine unsatkVG_dflcdpsi_from_psi(psi, alpha, n, m, l, dflcdpsi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: alpha !inverse of air-entry pressure [MPa-1] - real(r8), intent(in) :: n !pore-size distribution index [-] - real(r8), intent(in) :: m != 1 - 1/n_VG [-] - real(r8), intent(in) :: l !pore tortuosity parameter [-] - real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] - ! - ! !LOCAL VARIABLES: - real(r8) :: temp !temporary - real(r8) :: fac1a !temporary - real(r8) :: fac1b !temporary - real(r8) :: fac1 !temporary - real(r8) :: fac2 !temporary - real(r8) :: dtemp !temporary - real(r8) :: dfac1adpsi !temporary - real(r8) :: dfac1bdpsi !temporary - real(r8) :: dfac1dpsi !temporary - real(r8) :: dfac2dpsi !temporary - !------------------------------------------------------------------------------ - - temp = ( alpha*abs(psi) ) ** (n) - fac1a = ( alpha*abs(psi) ) ** (n-1._r8) - fac1b = ( 1._r8 + temp ) ** (-1._r8*m) - fac1 = ( 1._r8 - fac1a*fac1b ) ** (2._r8) - fac2 = ( 1._r8 + temp ) ** (-0.5_r8*m) - - dtemp = n * alpha * ( alpha*abs(psi) ) ** (n-1._r8) - dfac1adpsi = ( n-1._r8 ) * alpha * ( alpha*abs(psi) ) ** (n-2._r8) - dfac1bdpsi = ( -1._r8 ) * m * dtemp * ( 1._r8 + temp ) ** (-1._r8*m - 1._r8) - dfac1dpsi = ( 2._r8 ) * ( 1._r8 - fac1a*fac1b ) * ( -1._r8*dfac1bdpsi*fac1a - dfac1adpsi*fac1b ) - dfac2dpsi = ( -0.5_r8 ) * m * dtemp * (1._r8 + temp)**(-0.5_r8*m-1._r8) - - dflcdpsi = ( -1._r8 ) * ( dfac2dpsi*fac1 + dfac1dpsi*fac2 ) ! BOC... mult by -1 because unsatk eqn is based on abs(psi) - - end subroutine unsatkVG_dflcdpsi_from_psi - - !======================================================================- - subroutine unsatkCampbell_dflcdpsi_from_psi(psi, psisat, B, dflcdpsi) - ! - ! DESCRIPTION - ! van Genuchten (1980) soil water characteristic (retention) curve - ! returns derivative of water water potential with respect to water content - ! given saturation fraction and shape parameters - ! - !USES - ! - ! !ARGUMENTS: - real(r8), intent(in) :: psi !soil matric potential [MPa] - real(r8), intent(in) :: psisat !air-entry pressure [MPa] - real(r8), intent(in) :: B !shape parameter [-] - real(r8), intent(out) :: dflcdpsi !derivative of k/ksat (flc) wrt psi [MPa-1] - !------------------------------------------------------------------------------ - - - !flc = max(1._r8,psi/psisat)**(-2._r8-3._r8/B) - - ! FLC is well behaved at very very low values of psi (asymptotic) - ! Although, it is not well behaved at very high values, which - ! has a cap, and thus derivative of zero - if(psi>psisat) then - dflcdpsi = 0._r8 - else - !dflcdpsi = psisat*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) - dflcdpsi = (1._r8/psisat)*(-2._r8-3._r8/B)*(psi/psisat)**(-3._r8-3._r8/B) - end if - - ! flc = max(1._r8,psi/psisat)**(-2._r8-3._r8/B) - - ! (psi/psisat)**(-2._r8-3._r8/B-1._r8)*(1./psisat)*(-2._r8-2._r8/B) - - end subroutine unsatkCampbell_dflcdpsi_from_psi - - - - - -end module FatesHydroUnitFunctionsMod From c4092d4c8d1eb02ab180b7e6602947a62eea8072 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 19 Feb 2020 11:28:57 -0800 Subject: [PATCH 067/114] Cleaning up hydro-refactor, removing unused variables, cleaning up text and adding descriptions --- biogeophys/FatesHydroWTFMod.F90 | 315 +++++++++++----------- biogeophys/FatesPlantHydraulicsMod.F90 | 359 ++++++++++--------------- main/FatesHistoryInterfaceMod.F90 | 3 +- 3 files changed, 291 insertions(+), 386 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 23d1d79a70..713bfbf97c 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -28,10 +28,11 @@ module FatesHydroWTFMod __FILE__ - real(r8), parameter :: min_ftc = 0.0005_r8 + real(r8), parameter :: min_ftc = 0.0005_r8 ! Minimum allowed fraction of total conductance + - real(r8), parameter :: min_rwc_interp = 0.02 - real(r8), parameter :: max_rwc_interp = 0.95 + real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation above this saturated frac + real(r8), parameter :: max_sf_interp = 0.95 ! Linear interpolation below this saturated frac real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region @@ -116,7 +117,7 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] - real(r8) :: psi_max ! psi where rwc = rwc_max_interp, and use linear + real(r8) :: psi_max ! psi where satfrac = max_sf_interp, and use linear real(r8) :: dpsidth_max ! deriv wrt theta for psi_max contains procedure :: th_from_psi => th_from_psi_cch @@ -153,9 +154,9 @@ module FatesHydroWTFMod real(r8) :: cap_slp ! slope of capillary region of curve integer :: pmedia ! self describing porous media index - real(r8) :: psi_max ! psi matching max_rwc_interp where we start linear interp + real(r8) :: psi_max ! psi matching max_sf_interp where we start linear interp real(r8) :: dpsidth_max ! dpsi_dth where we start linear interp - real(r8) :: psi_min ! psi matching min_rwc_interp + real(r8) :: psi_min ! psi matching min_sf_interp real(r8) :: dpsidth_min ! dpsi_dth where we start min interp contains @@ -293,18 +294,15 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: satfrac ! Saturated fraction [-] real(r8) :: th ! Volumetric Water Cont [m3/m3] - real(r8) :: psi_interp ! psi where we start lin interp - real(r8) :: th_interp ! th where we start lin interp - real(r8) :: dpsidth_interp - real(r8) :: m + real(r8) :: psi_interp ! psi where we start lin interp + real(r8) :: th_interp ! th where we start lin interp + real(r8) :: dpsidth_interp@ ! change in psi during lin interp (slope) + real(r8) :: m ! pore size distribution param (1/n) m = 1._r8/this%psd ! pressure above which we use a linear function - psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m - - ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m - + psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(m-1._r8)) - 1._r8 )**m if(psi=max_rwc_interp) then + if(satfrac>=max_sf_interp) then - th_interp = max_rwc_interp * (this%th_sat-this%th_res) + this%th_res + th_interp = max_sf_interp * (this%th_sat-this%th_res) + this%th_res dpsidth_interp = this%dpsidth_from_th(th_interp) - psi_interp = -(1._r8/this%alpha)*(max_rwc_interp**(1._r8/(m-1._r8)) - 1._r8 )**m + psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(m-1._r8)) - 1._r8 )**m psi = psi_interp + dpsidth_interp*(th-th_interp) -!! elseif(satfracth_interp) then - satfrac = max_rwc_interp + satfrac = max_sf_interp else satfrac = (th-this%th_res)/(this%th_sat-this%th_res) end if @@ -519,7 +509,7 @@ subroutine set_wrf_param_cch(this,params_in) ! Set DERIVED constants ! used for interpolating in extreme ranges - th_max = max_rwc_interp*this%th_sat-1.e-9_r8 + th_max = max_sf_interp*this%th_sat-1.e-9_r8 this%psi_max = this%psi_from_th(th_max) this%dpsidth_max = this%dpsidth_from_th(th_max) @@ -550,7 +540,7 @@ function th_from_psi_cch(this,psi) result(th) if(psi>this%psi_max) then ! Linear range for extreme values - th = max_rwc_interp*this%th_sat + (psi-this%psi_max)/this%dpsidth_max + th = max_sf_interp*this%th_sat + (psi-this%psi_max)/this%dpsidth_max else th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) end if @@ -564,11 +554,11 @@ function psi_from_th_cch(this,th) result(psi) class(wrf_type_cch) :: this real(r8),intent(in) :: th real(r8) :: psi - real(r8) :: rwc + real(r8) :: satfrac - rwc = th/this%th_sat - if(rwc>max_rwc_interp) then - psi = this%psi_max + this%dpsidth_max*(th-max_rwc_interp*this%th_sat) + satfrac = th/this%th_sat + if(satfrac>max_sf_interp) then + psi = this%psi_max + this%dpsidth_max*(th-max_sf_interp*this%th_sat) else psi = this%psi_sat*(th/this%th_sat)**(-this%beta) end if @@ -670,8 +660,8 @@ subroutine set_wrf_param_tfs(this,params_in) ! Set DERIVED constants ! used for interpolating in extreme ranges - th_max=max_rwc_interp*(this%th_sat-this%th_res)+this%th_res-1.e-9_r8 - th_min=min_rwc_interp*(this%th_sat-this%th_res)+this%th_res+1.e-9_r8 + th_max=max_sf_interp*(this%th_sat-this%th_res)+this%th_res-1.e-9_r8 + th_min=min_sf_interp*(this%th_sat-this%th_res)+this%th_res+1.e-9_r8 this%psi_max = this%psi_from_th(th_max) this%dpsidth_max = this%dpsidth_from_th(th_max) this%psi_min = this%psi_from_th(th_min) @@ -702,21 +692,21 @@ function th_from_psi_tfs(this,psi) result(th) if(psi>this%psi_max) then ! Linear range for extreme values - th = this%th_res+max_rwc_interp*(this%th_sat-this%th_res) + & + th = this%th_res+max_sf_interp*(this%th_sat-this%th_res) + & (psi-this%psi_max)/this%dpsidth_max elseif(psimax_rwc_interp) then + real(r8) :: satfrac ! saturated fraction (between res and sat) - psi = this%psi_max + this%dpsidth_max * & - (th-(max_rwc_interp*(this%th_sat-this%th_res)+this%th_res)) - - elseif(rwcmax_sf_interp) then + psi = this%psi_max + this%dpsidth_max * & + (th-(max_sf_interp*(this%th_sat-this%th_res)+this%th_res)) + + elseif(satfracmax_rwc_interp) then + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + if(satfrac>max_sf_interp) then dpsidth = this%dpsidth_max - elseif(rwc use BC hydraulics; ! 2 => use CX hydraulics - ! The following options are temporarily unavailable (RGK 09-06-19) ! ---------------------------------------------------------------------------------- - ! logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf + ! logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf ! term be applied to the plant ! hydraulics numerical solution? - !logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling + ! logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling ! (i.e., non-instantaneous) be considered ! within plant hydraulics? - !logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the + ! logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the ! boundary between nodes be taken to be a ! function of the upstream loss of ! conductivity (flc)? + ! logical :: purge_supersaturation = .false. ! If for some reason the roots force water + ! ! into a saturated soil layer, or push it slightly + ! ! past saturation, should we attempt to help + ! ! fix the situation by assigning some + ! ! of the water to a runoff term? + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent - ! hydraulic properties and states be - ! updated every day when trees grow or - ! when recruitment happens? + ! hydraulic properties and states be + ! updated every day when trees grow or + ! when recruitment happens? ! If this is set to true, then the conductance over a path between nodes, is defined ! by the side of the path with higher potential only. logical, parameter :: do_upstream_k = .true. - logical :: purge_supersaturation = .false. ! If for some reason the roots force water - ! into a saturated soil layer, or push it slightly - ! past saturation, should we attempt to help fix the situation by assigning some - ! of the water to a runoff term? + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through ! the plant (in 1D solves) as closed from root layer @@ -159,24 +161,21 @@ module FatesPlantHydraulicsMod real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer ! is left between soil moisture and saturation [m3/m3] + ! (if we are going to help purge super-saturation) - logical,parameter :: debug = .true. !flag to report warning in hydro + logical,parameter :: debug = .true. ! flag to report warning in hydro character(len=*), parameter, private :: sourcefile = & __FILE__ - ! We use this parameter as the value for which we set un-initialized values - real(r8), parameter :: un_initialized = -9.9e32_r8 - integer, public, parameter :: van_genuchten_type = 1 integer, public, parameter :: campbell_type = 2 integer, public, parameter :: tfs_type = 3 integer, parameter :: plant_wrf_type = tfs_type integer, parameter :: plant_wkf_type = tfs_type - ! integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type @@ -190,7 +189,11 @@ module FatesPlantHydraulicsMod ! for plants of each different porous media type, and plant functional type class(wkf_arr_type), pointer :: wkf_plant(:,:) - + + ! Testing parameters for Van Genuchten soil WRTs + ! unused unless van_genuchten_type is selected, also + ! it would be much better to use the native parameters passed in + ! from the HLM's soil model real(r8), parameter :: alpha_vg = 0.001_r8 real(r8), parameter :: th_sat_vg = 0.65_r8 real(r8), parameter :: th_res_vg = 0.15_r8 @@ -290,17 +293,17 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! locals ! ---------------------------------------------------------------------------------- ! LL pointers - type(ed_patch_type),pointer :: cpatch ! current patch - type(ed_cohort_type),pointer :: ccohort ! current cohort - type(ed_cohort_hydr_type),pointer :: ccohort_hydr - type(ed_site_hydr_type),pointer :: csite_hydr - integer :: s ! site loop counter - integer :: j - integer :: j_bc ! soil layer index of boundary condition - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch + type(ed_patch_type),pointer :: cpatch ! current patch + type(ed_cohort_type),pointer :: ccohort ! current cohort + type(ed_cohort_hydr_type),pointer :: ccohort_hydr + type(ed_site_hydr_type),pointer :: csite_hydr + integer :: s ! site loop counter + integer :: j ! soil layer index + integer :: j_bc ! soil layer index of boundary condition + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch do s = 1,nsites csite_hydr=>sites(s)%si_hydr @@ -333,9 +336,9 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) cpatch => cpatch%younger end do - sites(s)%si_hydr%l_aroot_layer_init(:) = un_initialized - sites(s)%si_hydr%r_node_shell_init(:,:) = un_initialized - sites(s)%si_hydr%v_shell_init(:,:) = un_initialized + sites(s)%si_hydr%l_aroot_layer_init(:) = fates_unset_r8 + sites(s)%si_hydr%r_node_shell_init(:,:) = fates_unset_r8 + sites(s)%si_hydr%v_shell_init(:,:) = fates_unset_r8 ! -------------------------------------------------------------------------------- ! Initialize water transfer functions @@ -345,8 +348,6 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! -------------------------------------------------------------------------------- ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- - - select case(soil_wrf_type) case(van_genuchten_type) @@ -436,15 +437,14 @@ subroutine InitTreeHydStates(site, cohort) ! !LOCAL VARIABLES: type(ed_site_hydr_type), pointer :: site_hydr type(ed_cohort_hydr_type), pointer :: cohort_hydr - integer :: j,k,ft ! indices - real(r8) :: psi_rhiz1 - real(r8) :: dz - real(r8) :: smp - real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots - - real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa - real(r8), parameter :: dh_dz = 0.02_r8 ! amount to decrease downstream - ! compartment total potentials [MPa/meter] + integer :: j,k ! layer and node indices + integer :: ft ! functional type index + real(r8) :: psi_rhiz1 ! pressure in first rhizosphere shell [MPa] + real(r8) :: dz ! depth of the current layer [m] + real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots + real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa + real(r8), parameter :: dh_dz = 0.02_r8 ! amount to decrease downstream + ! compartment total potentials [MPa/meter] ! In init mode = 1, set absorbing roots to -0.2 MPa ! = 2, use soil as starting point, match total potentials @@ -1087,9 +1087,6 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot ! BC PLANT HYDRAULICS - flux terms - -! ncohort_hydr%sapflow = ocohort_hydr%sapflow -! ncohort_hydr%rootuptake = ocohort_hydr%rootuptake ncohort_hydr%qtop = ocohort_hydr%qtop ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited @@ -2056,23 +2053,23 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) type(bc_out_type), intent(inout) :: bc_out(nsites) ! Locals - real(r8) :: dwat_kgm2 ! change in layer water content [kg/m2] - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s,j,k ! site, soil layer, rhizosphere shell indicies - integer :: i,f,ff,kk ! indicies - integer :: j_bc ! layer index for matching boundary condition soil layers - integer :: indexj ! column and layer indices where there is a water balance error - integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered - real(r8) :: area_col ! column area [m2] - real(r8) :: v_cum ! cumulative shell volume from driest/wettest shell to kth shell [m3] - real(r8) :: dwat_kg ! water remaining to be distributed across shells [kg] - real(r8) :: thdiff ! water content difference between ordered adjacent rhiz shells [m3 m-3] - real(r8) :: wdiff ! mass of water represented by thdiff over previous k shells [kg] - real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] - real(r8) :: cumShellH2O ! sum of water in all the shells of a specific layer [kg/m2] - real(r8) :: h2osoi_liq_shell(nlevsoi_hyd_max,nshell) !water in the rhizosphere shells [kg] - integer :: tmp ! temporary - logical :: found ! flag in search loop + type(ed_site_hydr_type), pointer :: csite_hydr ! pointer to site hydraulics object + real(r8) :: dwat_kgm2 ! change in layer water content [kg/m2] + integer :: s,j,k ! site, soil layer, rhizosphere shell indicies + integer :: i,f,ff,kk ! indicies + integer :: j_bc ! layer index for matching boundary condition soil layers + integer :: indexj ! column and layer indices where there is a water balance error + integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered + real(r8) :: area_col ! column area [m2] + real(r8) :: v_cum ! cumulative shell volume from driest/wettest shell to kth shell [m3] + real(r8) :: dwat_kg ! water remaining to be distributed across shells [kg] + real(r8) :: thdiff ! water content difference between ordered adjacent rhiz shells [m3 m-3] + real(r8) :: wdiff ! mass of water represented by thdiff over previous k shells [kg] + real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] + real(r8) :: cumShellH2O ! sum of water in all the shells of a specific layer [kg/m2] + real(r8) :: h2osoi_liq_shell(nlevsoi_hyd_max,nshell) ! water in the rhizosphere shells [kg] + integer :: tmp ! temporary + logical :: found ! flag in search loop !----------------------------------------------------------------------- do s = 1,nsites @@ -2199,109 +2196,63 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! ! !LOCAL VARIABLES: - character(len=*), parameter :: sub = 'clm::Hydraulics_bc' - integer :: iv ! leaf layer - integer :: ifp ! index of FATES patch - integer :: s ! index of FATES site - integer :: i ! shell index - integer :: j,jj! soil layer - integer :: j_bc! soil layer index for boundary conditions - integer :: k ! 1D plant-soil continuum array - integer :: ft ! plant functional type index - integer :: t ! previous timesteps (for lwp stability calculation) + integer :: iv ! leaf layer + integer :: ifp ! index of FATES patch + integer :: s ! index of FATES site + integer :: i ! shell index + integer :: j,jj ! soil layer + integer :: j_bc ! soil layer index for boundary conditions + integer :: k ! 1D plant-soil continuum array + integer :: ft ! plant functional type index + integer :: t ! previous timesteps (for lwp stability calculation) integer :: nstep !number of time steps !---------------------------------------------------------------------- - type (ed_patch_type), pointer :: cpatch - type (ed_cohort_type), pointer :: ccohort - - ! hydraulics global constants - - real(r8), parameter :: small_theta_num = 1.e-5_r8 ! avoids theta values equalling thr or ths [m3 m-3] - - ! hydraulics timestep adjustments for acceptable water balance error - - real(r8) :: we_area_outer ! 1D plant-soil continuum water error [kgh2o m-2 individual-1] - - ! column-specific arrays to hold rhizosphere geometric & state variables - real(r8) :: h2osoi_liqvol - real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create - ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] - real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) ! accumulated water content change over all cohorts in a column [m3 m-3] + type (ed_patch_type), pointer :: cpatch ! current patch pointer + type (ed_cohort_type), pointer :: ccohort ! current cohort pointer + type(ed_site_hydr_type), pointer :: site_hydr ! site hydraulics pointer + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer - real(r8) :: aroot_frac_plant ! The fraction of the total lenght of absorbing roots contained in one soil layer - ! that are devoted to a single plant + ! Local arrays - real(r8) :: kbg_layer(nlevsoi_hyd_max) ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: psi_aroot ! matric potential in absorbing root [MPa] - real(r8) :: ftc_aroot ! fraction of total conductance in absorbing root [-] - real(r8) :: psi_shell ! matric potential of a given shell [-] - real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] - real(r8) :: kmax_up ! Kmax of upper rhizosphere compartments [kg s-1 Mpa-1] - real(r8) :: kmax_lo ! Kamx of lower rhizosphere compartments [kg s-1 Mpa-1] + ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) - real(r8) :: wb_err_plant ! Solve error for a single plant [kg] - real(r8) :: wb_check_site ! the water balance error we get from summing fluxes - ! and changes in storage - ! and is just a double check on our error accounting). [kg/m2] + ! array of soil layer indices which have been ordered + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) - real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] + ! number of cohorts in this size-class/pft bin (nlevsclass,numpft) for averaging + integer,allocatable :: ncohorts_scpf(:,:) -! real(r8) :: supsub_error ! Amount of mass created or destroyed to prevent super-saturation -! ! or sub-residual water contents from occuring in the soil [kg/m2] + ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: kbg_layer(nlevsoi_hyd_max) - integer,allocatable :: ncohorts_scpf(:,:)!nlevsclass,numpft) - ! hydraulics other - integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) ! array of soil layer indices which have been ordered - real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] - real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch - real(r8) :: qtop_dt - real(r8) :: dqtopdth_dthdt - real(r8) :: sapflow - real(r8) :: rootuptake - real(r8) :: totalrootuptake !total root uptake per unit area (kg h2o m-2 time step -1) - real(r8) :: transp_col ! Column mean transpiration rate [mm H2O/m2] - ! as defined by the input boundary condition - real(r8) :: transp_col_check ! Column mean transpiration rate [mm H2O/m2] as defined - ! by the sum of water fluxes through the cohorts - - - real(r8) :: patch_wgt ! fraction of current patch relative to the whole site - ! note that this is almost but not quite cpatch%area/AREA - ! as it regards the fraction of canopy area as the relevant - ! area, and assumes that the HLM has it's own patch - ! that is not tracked by FATES which accounts for all - ! non-canopy areas across all patches - - real(r8) :: smp ! temporary for matric potential (MPa) - integer :: tmp - integer :: jtop, jbot ! indices of the top and bottom rhizosphere layer - ! relative to the boundary condition array - real(r8) :: tmp1 - real(r8) :: watres_local - real(r8) :: roota, rootb ! parameters for root distribution [m-1] - real(r8) :: rootfr ! root fraction at different soil layers - real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) - real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) - logical :: recruitflag ! flag to check if there is newly recruited cohorts - integer :: iter ! number of solver iterations used for each cohort x layer - real(r8) :: root_flux - real(r8) :: transp_flux - real(r8) :: delta_plant_storage - real(r8) :: delta_soil_storage - real(r8) :: mean_theta ! mean water content per soil layer (testing) [m3/m3] - integer :: sc ! size class index - type(ed_site_hydr_type), pointer :: site_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - integer :: err_code = 0 - - logical, parameter :: weight_serial_dt = .false. ! For serial solver (1D), should - ! the fractional time each layer - ! gets, be weighted by conductance? + real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create + ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] + real(r8) :: aroot_frac_plant ! The fraction of the total length of absorbing roots contained in one soil layer + ! that are devoted to a single plant + real(r8) :: wb_err_plant ! Solve error for a single plant [kg] + real(r8) :: wb_check_site ! the water balance error we get from summing fluxes + ! and changes in storage + ! and is just a double check on our error accounting). [kg/m2] + real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] + real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] + real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch + real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] + real(r8) :: rootuptake ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/step] + real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) + real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) + logical :: recruitflag ! flag to check if there is newly recruited cohorts + real(r8) :: root_flux ! total water flux into roots [kg/m2] + real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] + real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] + real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] + integer :: sc ! size class index + ! ---------------------------------------------------------------------------------- ! Important note: We are interested in calculating the total fluxes in and out of the ! site/column. Usually, when we do things like this, we acknowledge that FATES @@ -2310,12 +2261,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! are only accounting for a portion of the area. ! ---------------------------------------------------------------------------------- - ! DEPRECATED: waterstate_inst%psisoi_liq_shell - ! Input: [real(r8) (:,:,:)] soil matric potential (MPa) by layer and rhizosphere shell - - !for debug only - !nstep = get_nstep() - !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) @@ -2345,7 +2290,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! -------------------------------------------------------------------------------- transp_flux = 0._r8 root_flux = 0._r8 - ! Initialize the delta in soil water and plant water storage ! with the initial condition. @@ -2360,11 +2304,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! ------------------------------------------------- ifp = 0 cpatch => sites(s)%oldest_patch - transp_col = 0.0_r8 do while (associated(cpatch)) ifp = ifp + 1 patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area*AREA_INV) - transp_col = transp_col + bc_in(s)%qflx_transp_pa(ifp)*patch_wgt cpatch => cpatch%younger end do @@ -2406,8 +2348,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft -! ccohort_hydr%rootuptake = 0._r8 - ! Relative transpiration of this cohort from the whole patch ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] @@ -2488,8 +2428,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_err_plant,dwat_plant, & dth_layershell_col) - - end if ! Remember the error for the cohort @@ -2628,13 +2566,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! mass balance check and pass the total stored vegetation water to HLM ! in order for it to fill its balance checks - !remove the recruitment water uptake as it has been added to prev_h2oveg - - jtop = site_hydr%i_rhiz_t - jbot = site_hydr%i_rhiz_b - totalrootuptake = sum(bc_out(s)%qflx_soil2root_sisl(jtop:jbot) - & - site_hydr%recruit_w_uptake(:))*dtime - ! Compare the integrated error to the site mass balance ! error sign is positive towards transpiration overestimation @@ -2722,36 +2653,33 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) type(ed_site_hydr_type),intent(in),target :: csite_hydr ! Locals - integer :: k ! Compartment (node) index - integer :: j ! Soil layer index - integer :: k_ag ! Compartment index for above-ground indexed array - integer :: pft ! Plant Functional Type index - real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] - real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] - real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] - real(r8) :: z_node ! distance between compartment center and mph [m] - real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] - real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways - ! [kg-1 s MPa] - real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways - real(r8) :: kmax_bg_alt - ! from the absorbing roots center nodes to the - ! transporting root center node - real(r8) :: rootfr ! fraction of absorbing root in each soil layer - ! assumes propotion of absorbing root is equal - ! to proportion of total root - real(r8) :: kmax_layer ! max conductance between transporting root node - ! and absorbing root node in each layer [kg s-1 MPa-1] + integer :: k ! Compartment (node) index + integer :: j ! Soil layer index + integer :: k_ag ! Compartment index for above-ground indexed array + integer :: pft ! Plant Functional Type index + real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] + real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] + real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] + real(r8) :: z_node ! distance between compartment center and mph [m] + real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] + real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways + ! [kg-1 s MPa] + real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + ! from the absorbing roots center nodes to the + ! transporting root center node + real(r8) :: rootfr ! fraction of absorbing root in each soil layer + ! assumes propotion of absorbing root is equal + ! to proportion of total root + real(r8) :: kmax_layer ! max conductance between transporting root node + ! and absorbing root node in each layer [kg s-1 MPa-1] real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each - ! soil layer [m2] - real(r8) :: roota ! root profile parameter a zeng2001_crootfr - real(r8) :: rootb ! root profile parameter b zeng2001_crootfr - real(r8) :: sum_l_aroot ! sum of plant's total root length - - + ! soil layer [m2] + real(r8) :: roota ! root profile parameter a zeng2001_crootfr + real(r8) :: rootb ! root profile parameter b zeng2001_crootfr + real(r8) :: sum_l_aroot ! sum of plant's total root length real(r8),parameter :: taper_exponent = 1._r8/3._r8 ! Savage et al. (2010) xylem taper exponent [-] real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference ! in the top of stem and petiole @@ -3045,7 +2973,6 @@ end subroutine OrderLayersForSolve1D ! ================================================================================= - subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ordered,kbg_layer, sapflow,rootuptake,& wb_err_plant,dwat_plant,dth_layershell_col) @@ -3076,20 +3003,17 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Arguments (OUT) - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] - real(r8),intent(out) :: wb_err_plant ! total error from the plant, transpiration - ! should match change in storage [kg] - - real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] - - + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: wb_err_plant ! total error from the plant, transpiration + ! should match change in storage [kg] + real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] real(r8),intent(inout) :: dth_layershell_col(:,:) ! accumulated water content change over all cohorts in a column [m3 m-3]) ! Locals integer :: i ! node index "i" integer :: j ! path index "j" - integer :: jj + integer :: jj ! alt path index integer :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows integer :: ilayer ! soil layer index of interest integer :: itest ! node index used for testing and reporting errors @@ -3159,8 +3083,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & logical, parameter :: no_ftc_radialk = .false. - logical, parameter :: do_scale_allkmax_rootfr = .true. - logical, parameter :: weight_serial_dt = .true. + logical, parameter :: weight_serial_dt = .true. ! if this is true, and we are not doing spatial parallelism + ! then we give the fraction of time as a function of how + ! much conductance the layer has associate(pm_node => site_hydr%pm_node) @@ -3168,6 +3093,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! (each soil layer has a different number, this saves the max) cohort_hydr%iterh1 = 0 cohort_hydr%iterh2 = 0 + ! Initialize plant water error (integrated flux-storage) wb_err_plant = 0._r8 @@ -3694,13 +3620,6 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & write(fates_log(),*) cohort_hydr%l_aroot_layer(ilayer) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - - if( any(dth_node(:).ne.dth_node(:)) ) then - print*,"Broken solve" - print*,"dth_node:",dth_node(:) - stop - end if dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3a436148d9..fd7a515d13 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3333,8 +3333,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) do ipft = 1, numpft do iscls = 1,nlevsclass iscpf = (ipft-1)*nlevsclass + iscls - hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & - sites(s)%si_hydr%sapflow(iscls, ipft) ! [kg/indiv/s] + hio_sapflow_scpf(io_si,iscpf) = sites(s)%si_hydr%sapflow(iscls, ipft) ! [kg/indiv/s] end do end do From b719c9f73bc86d1b62cd2d0e5b915dde502a16e4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 20 Feb 2020 13:52:43 -0800 Subject: [PATCH 068/114] fates hydro, cleaning code, fixing sapflux diagnostic --- biogeophys/FatesHydroWTFMod.F90 | 2 +- biogeophys/FatesPlantHydraulicsMod.F90 | 62 +++++++++++++------------- 2 files changed, 31 insertions(+), 33 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 713bfbf97c..219cad3aba 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -296,7 +296,7 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: psi_interp ! psi where we start lin interp real(r8) :: th_interp ! th where we start lin interp - real(r8) :: dpsidth_interp@ ! change in psi during lin interp (slope) + real(r8) :: dpsidth_interp ! change in psi during lin interp (slope) real(r8) :: m ! pore size distribution param (1/n) m = 1._r8/this%psd diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 34abe22004..7fbecebf56 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -131,11 +131,14 @@ module FatesPlantHydraulicsMod ! boundary between nodes be taken to be a ! function of the upstream loss of ! conductivity (flc)? - ! logical :: purge_supersaturation = .false. ! If for some reason the roots force water - ! ! into a saturated soil layer, or push it slightly - ! ! past saturation, should we attempt to help - ! ! fix the situation by assigning some - ! ! of the water to a runoff term? + + ! DO NOT TURN THIS ON. LEAVING THIS ONLY IF THE HLMS START HAVING + ! TROUBLE RESPONDING TO SUPERSATURATION + logical :: purge_supersaturation = .false. ! If for some reason the roots force water + ! into a saturated soil layer, or push it slightly + ! past saturation, should we attempt to help + ! fix the situation by assigning some + ! of the water to a runoff term? logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent @@ -2297,20 +2300,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) !err_soil = delta_soil_storage - root_flux !err_plot = delta_plant_storage - (root_flux - transp_flux) - - ! Calculate the mean site level transpiration flux - ! This is usefull to check on mass conservation - ! of cohort level fluxes - ! ------------------------------------------------- - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp = ifp + 1 - patch_wgt = min(1.0_r8,cpatch%total_canopy_area/cpatch%area) * (cpatch%area*AREA_INV) - cpatch => cpatch%younger - end do - - ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) @@ -3037,7 +3026,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & real(r8) :: leaf_water ! kg of water in the leaf real(r8) :: stem_water ! kg of water in the stem real(r8) :: root_water ! kg of water in the transp and absorbing roots - + real(r8) :: sapflow_lyr ! sapflow flux [kg] per layer per timestep + real(r8) :: rootuptake_lyr! rootuptake flux [kg] per layer per timestep real(r8) :: wb_err_layer ! balance error for the layer [kg/cohort] @@ -3104,9 +3094,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! in this routine (uses differentials and actual fluxes) ! So we need to zero them, as they are incremented ! over the sub-steps - - sapflow = 0._r8 - rootuptake = 0._r8 + sapflow = 0._r8 + rootuptake = 0._r8 ft = cohort%pft @@ -3218,6 +3207,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & flux_diag = 0._r8 end if + sapflow_lyr = 0._r8 + rootuptake_lyr = 0._r8 + ! For each attempt, we want to reset theta with the initial value th_node(:) = th_node_init(:) @@ -3513,7 +3505,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! [kg] = [kg/s] * [s] i = n_hypool_ag - sapflow = sapflow + dt_substep * & + sapflow_lyr = sapflow_lyr + dt_substep * & (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) A_term(i)*dth_node(i) + & ! dq at node i B_term(i)*dth_node(i+1)) ! dq at node i+1 @@ -3522,7 +3514,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! shell and the absorbing root i = n_hypool_ag+2 - rootuptake = rootuptake + dt_substep * & + rootuptake_lyr = rootuptake_lyr + dt_substep * & (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) A_term(i)*dth_node(i) + & ! dq at node i B_term(i)*dth_node(i+1)) ! dq at node i+1 @@ -3530,13 +3522,13 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! If debug mode is on, lets also track the mass fluxes across each ! path, and keep a running average of the effective conductances if(debug)then - do j=1,n_hypool_tot-1 - k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step - flux_diag(j) = flux_diag(j) + dt_substep * ( & - k_eff(j)*(h_node(j+1)-h_node(j)) + & - A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) - end do - end if + do j=1,n_hypool_tot-1 + k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step + flux_diag(j) = flux_diag(j) + dt_substep * ( & + k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) + end do + end if end do ! do istep = 1,nsteps (substep loop) @@ -3576,6 +3568,12 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & dth_node(:) = th_node(:)-th_node_init(:) + + ! Add the current soil layer's contribution to total + ! sap and root flux [kg] + sapflow = sapflow + sapflow_lyr + rootuptake = rootuptake + rootuptake_lyr + ! Record the layer with the most iterations, but only ! if it greater than 1. It will default to zero From 00d4fd56959743a8ea123479574110f4248c6499 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 13 Mar 2020 14:39:46 -0700 Subject: [PATCH 069/114] partially though an update tri-diagonal error checking, root psi initialization and leaf volumes --- biogeophys/FatesPlantHydraulicsMod.F90 | 245 ++++++++++++------------- 1 file changed, 122 insertions(+), 123 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 7fbecebf56..5890c94814 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -203,6 +203,9 @@ module FatesPlantHydraulicsMod real(r8), parameter :: psd_vg = 2.7_r8 real(r8), parameter :: tort_vg = 0.5_r8 + ! The maximum allowable water balance error over a plant-soil continuum + ! for a given step [kgs] (0.1 mg) + real(r8), parameter :: max_wb_step_err = 1.e-7_r8 ! ! !PUBLIC MEMBER FUNCTIONS: @@ -465,7 +468,7 @@ subroutine InitTreeHydStates(site, cohort) if(init_mode == 2) then - h_aroot_mean = 0._r8 +! h_aroot_mean = 0._r8 do j=1, site_hydr%nlevrhiz @@ -473,7 +476,7 @@ subroutine InitTreeHydStates(site, cohort) cohort_hydr%psi_aroot(j) = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) ! Calculate the mean total potential (include height) of absorbing roots - h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) +! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) @@ -484,14 +487,15 @@ subroutine InitTreeHydStates(site, cohort) do j=1, site_hydr%nlevrhiz cohort_hydr%psi_aroot(j) = psi_aroot_init ! Calculate the mean total potential (include height) of absorbing roots - h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) +! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) cohort_hydr%th_aroot(j) = wrf_plant(aroot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) - + !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) + h_aroot_mean = min(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:)) + ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) ! the assumption is made here that initial conditions for soil water will ! be in (or at least close to) hydrostatic equilibrium as well, so that @@ -544,9 +548,10 @@ subroutine InitTreeHydStates(site, cohort) !flc_gs_from_psi(cohort_hydr%psi_ag(1),cohort%pft) - ! Check plant pressures, make sure they are not positive + ! We do allow for positive pressures. + ! But starting off with positive pressures is something we try to avoid if ( (cohort_hydr%psi_troot>0.0_r8) .or. & - any(cohort_hydr%psi_ag(:)>0._r8) .or. & + any(cohort_hydr%psi_ag(:)>0._r8) .or. & any(cohort_hydr%psi_aroot(:)>0._r8) ) then write(fates_log(),*) 'Initialized plant compartments with positive pressure?' write(fates_log(),*) 'psi troot: ',cohort_hydr%psi_troot @@ -777,18 +782,9 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) real(r8) :: fnrt_c ! Current amount of fine-root carbon in the plant [kg] real(r8) :: sapw_c ! Current amount of sapwood carbon in the plant [kg] real(r8) :: struct_c ! Current amount of structural carbon in the plant [kg] - real(r8) :: b_canopy_carb ! total leaf (canopy) biomass in carbon units [kgC/indiv] - real(r8) :: b_canopy_biom ! total leaf (canopy) biomass in dry wt units [kg/indiv] - real(r8) :: b_woody_carb ! total woody biomass in carbon units [kgC/indiv] - real(r8) :: b_woody_bg_carb ! belowground woody biomass in carbon units [kgC/indiv] - real(r8) :: b_stem_carb ! aboveground stem biomass in carbon units [kgC/indiv] - real(r8) :: b_stem_biom ! aboveground stem biomass in dry wt units [kg/indiv] - real(r8) :: b_bg_carb ! belowground biomass (coarse + fine roots) in carbon units [kgC/indiv] - real(r8) :: b_tot_carb ! total individual biomass in carbon units [kgC/indiv] - real(r8) :: v_stem ! aboveground stem volume [m3/indiv] + real(r8) :: woody_bg_carb ! belowground woody biomass in carbon units [kgC/indiv] real(r8) :: z_stem ! the height of the plants stem below crown [m] real(r8) :: sla ! specific leaf area [cm2/g] - real(r8) :: v_canopy ! total leaf (canopy) volume [m3/indiv] real(r8) :: v_aroot_tot ! total compartment volume of all absorbing roots for cohort [m3] real(r8) :: l_aroot_tot ! total length of absorbing roots for cohrot [m] real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] @@ -814,112 +810,97 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) roota = EDPftvarcon_inst%roota_par(ft) rootb = EDPftvarcon_inst%rootb_par(ft) - !roota = 4.372_r8 ! TESTING: deep (see Zeng 2001 Table 1) - !rootb = 0.978_r8 ! TESTING: deep (see Zeng 2001 Table 1) - !roota = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) - !rootb = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) - - if(leaf_c > 0._r8) then - - - ! ------------------------------------------------------------------------------ - ! Part 1. Set the volumes of the leaf, stem and root compartments - ! and lenghts of the roots - ! ------------------------------------------------------------------------------ - - b_woody_carb = sapw_c + struct_c - b_woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_woody_carb - b_tot_carb = sapw_c + struct_c + leaf_c + fnrt_c - b_canopy_carb = leaf_c - b_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * b_tot_carb - b_canopy_biom = b_canopy_carb * EDPftvarcon_inst%c2b(ft) - - ! NOTE: SLATOP currently does not use any vertical scaling functions - ! but that may not be so forever. ie sla = slatop (RGK-082017) - ! m2/gC * cm2/m2 -> cm2/gC - sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 - - ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 - v_canopy = b_canopy_biom / denleaf - - ccohort_hydr%v_ag(1:n_hypool_leaf) = v_canopy / real(n_hypool_leaf,r8) - - - b_stem_carb = b_tot_carb - b_bg_carb - b_canopy_carb - b_stem_biom = b_stem_carb * EDPftvarcon_inst%c2b(ft) - - !BOC...may be needed for testing/comparison w/ v_sapwood - ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 - v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft)*1.e3_r8 ) - - ! calculate the sapwood cross-sectional area - call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,bsw_target) - a_sapwood = a_sapwood_target - - ! Alternative ways to calculate sapwood cross section - ! or .... - ! a_sapwood = a_sapwood_target * ccohort%bsw / bsw_target - - ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(ft)*1.e-4_r8 - ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 - ! or ... - !a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - - call CrownDepth(ccohort%hite,crown_depth) - z_stem = ccohort%hite - crown_depth - v_sapwood = a_sapwood * z_stem - ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem - + ! Leaf Volumes + ! ----------------------------------------------------------------------------------- - ! Determine belowground biomass as a function of total (sapwood, heartwood, - ! leaf, fine root) biomass then subtract out the fine root biomass to get - ! coarse (transporting) root biomass + ! NOTE: SLATOP currently does not use any vertical scaling functions + ! but that may not be so forever. ie sla = slatop (RGK-082017) + ! m2/gC * cm2/m2 -> cm2/gC + + sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 + + ! empirical regression data from leaves at Caxiuana (~ 8 spp) + denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 + + ! Leaf volumes + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] + ccohort_hydr%v_ag(1:n_hypool_leaf) = leaf_c * EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + - v_troot = b_woody_bg_carb * EDPftvarcon_inst%c2b(ft) / & - (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) + ! Step sapwood volume + ! ----------------------------------------------------------------------------------- + !BOC...may be needed for testing/comparison w/ v_sapwood + ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 + ! v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft) * kg_per_g * cm3_per_m3 ) - ! Estimate absorbing root total length (all layers) - ! SRL is in m/g - ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] - ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + ! calculate the sapwood cross-sectional area + call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,bsw_target) + a_sapwood = a_sapwood_target + ! Alternative ways to calculate sapwood cross section + ! or .... + ! a_sapwood = a_sapwood_target * ccohort%bsw / bsw_target + ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(ft)*1.e-4_r8 + ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 + ! or ... + ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - ! Estimate absorbing root volume (all layers) - ! ------------------------------------------------------------------------------ - v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * & - l_aroot_tot + call CrownDepth(ccohort%hite,crown_depth) + z_stem = ccohort%hite - crown_depth + v_sapwood = a_sapwood * z_stem + ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem - ! Total amount of root volume - v_root = v_aroot_tot + v_troot - ! The transporting root donates some of its volume - ! to the layer-by-layer absorbing root (which is now a hybrid compartment) + ! Determine belowground biomass as a function of total (sapwood, heartwood, + ! leaf, fine root) biomass then subtract out the fine root biomass to get + ! coarse (transporting) root biomass - ccohort_hydr%v_troot = 0.35 * v_root + woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) + + v_troot = b_woody_bg_carb * EDPftvarcon_inst%c2b(ft) / & + (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) + + + ! Estimate absorbing root total length (all layers) + ! SRL is in m/g + ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] + ! ------------------------------------------------------------------------------ + l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + + + ! Estimate absorbing root volume (all layers) + ! ------------------------------------------------------------------------------ + v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * l_aroot_tot - ! Partition the total absorbing root lengths and volumes into the active soil layers - ! We have a condition, where we may ignore the first layer - ! ------------------------------------------------------------------------------ + ! Total amount of root volume + v_root = v_aroot_tot + v_troot + + ! The transporting root donates some of its volume + ! to the layer-by-layer absorbing root (which is now a hybrid compartment) + + ccohort_hydr%v_troot = 0.35 * v_root + + ! Partition the total absorbing root lengths and volumes into the active soil layers + ! We have a condition, where we may ignore the first layer + ! ------------------------------------------------------------------------------ + + norm = 1._r8 - & + zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + + do j=1,nlevrhiz + + rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & + zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot + + ! This is a hybrid absorbing root and transporting root volume + ccohort_hydr%v_aroot_layer(j) = rootfr*(0.65*v_root) - norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + end do - do j=1,nlevrhiz - - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) - - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - - ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(0.65*v_root) - end do - - end if !check for bleaf - + return end subroutine UpdateTreeHydrLenVol ! ===================================================================================== @@ -957,8 +938,20 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) - ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself -- apply water mass conservation) - do k=1,n_hypool_ag + ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself + ! -- apply water mass conservation) + + do k=1,n_hypool_leaf + if( ccohort_hydr%v_ag(k) > nearzero) then + th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & + ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) + ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, pm_node(k)) + else + + end if + end do + + do k=n_hypool_leaf+1,n_hypool_ag th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, pm_node(k)) @@ -3012,6 +3005,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & integer :: i_up ! node index on the upstream side of flow path (towards soil) integer :: i_dn ! node index on the downstream side of flow path (towards atm) integer :: istep ! sub-step count index + integer :: tri_ierr ! error flag for the tri-diagonal solver 0=passed, 1=failed logical :: solution_found ! logical set to true if a solution was found within error tolerance real(r8) :: dt_step ! time [seconds] over-which to calculate solution real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] @@ -3068,7 +3062,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps ! by this much integer, parameter :: max_iter = 20 ! Maximum number of iterations with which we reduce timestep - real(r8), parameter :: max_wb_step_err = 1.e-7_r8 + real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [kg h2o] @@ -3446,8 +3440,14 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Calculate the change in theta - call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node) + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) + if(tri_ierr == 1) then + solution_found = .false. + error_code = 2 + error_arr(:) = 0._r8 + exit + end if ! If we have not broken from the substep loop, ! that means this sub-step has been acceptable, and we may @@ -4221,7 +4221,7 @@ end function xylemtaper ! ===================================================================================== - subroutine Hydraulics_Tridiagonal(a, b, c, r, u) + subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) ! ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 ! @@ -4240,6 +4240,7 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix real(r8), intent(out) :: u(:) ! solution + integer, intent(out) :: ierr ! flag: 0=passed, 1=failed ! ! !LOCAL VARIABLES: real(r8) :: bet ! temporary @@ -4250,7 +4251,6 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) real(r8) :: rel_err ! relative error, normalized by delta theta real(r8), parameter :: allowable_rel_err = 0.0001_r8 - ! real(r8), parameter :: allowable_err = 1.e-6_r8 !---------------------------------------------------------------------- N=size(r,dim=1) bet = b(1) @@ -4269,9 +4269,9 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u) enddo ! If debug mode, calculate error on the forward solution + ierr = 0 if(debug)then do k=1,N - if(k==1)then err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) elseif(knearzero)then rel_err = abs(err/u(k)) - - if((rel_err > allowable_rel_err)) then !.and. (err > allowable_err) )then + if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. + (err /= err) )then write(fates_log(),*) 'Tri-diagonal solve produced solution with' write(fates_log(),*) 'non-negligable error.' write(fates_log(),*) 'Compartment: ',k write(fates_log(),*) 'Error in forward solution: ',err write(fates_log(),*) 'Estimated delta theta: ',u(k) write(fates_log(),*) 'Rel Error: ',rel_err - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'Reducing time-step' + ierr = 1 end if end if - end do end if From 092523c1bd5e58be81c61863376f11bb2684e5df Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 15 Mar 2020 11:29:56 -0700 Subject: [PATCH 070/114] Cleaned up some functional unit testing routines --- .../allometry/simple_build.sh | 1 + .../hydro/build_hydro_f90_objects.sh | 2 - .../hydro/f90_src/EDParamsHydroMod.F90 | 61 ------------------- 3 files changed, 1 insertion(+), 63 deletions(-) delete mode 100644 functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 diff --git a/functional_unit_testing/allometry/simple_build.sh b/functional_unit_testing/allometry/simple_build.sh index a06b9724b0..114c82a15d 100755 --- a/functional_unit_testing/allometry/simple_build.sh +++ b/functional_unit_testing/allometry/simple_build.sh @@ -20,6 +20,7 @@ sed -i "/implicit none/i $new_fates_int_str" f90src/FatesConstantsMod.F90 sed -i "/$old_fates_r8_str/d" f90src/FatesConstantsMod.F90 sed -i "/$old_fates_int_str/d" f90src/FatesConstantsMod.F90 +sed -i "/private/d" f90src/FatesConstantsMod.F90 # This re-writes the wrapper so that it uses all the correct parameters # in FatesAllometryMod.F90 diff --git a/functional_unit_testing/hydro/build_hydro_f90_objects.sh b/functional_unit_testing/hydro/build_hydro_f90_objects.sh index 63cb80a7dc..75b6fe41f3 100755 --- a/functional_unit_testing/hydro/build_hydro_f90_objects.sh +++ b/functional_unit_testing/hydro/build_hydro_f90_objects.sh @@ -38,8 +38,6 @@ sed -i "/$old_fates_int_str/d" f90_src/FatesConstantsMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o f90_src/FatesConstantsMod.F90 -#${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/EDParamsHydroMod.o f90_src/EDParamsHydroMod.F90 - ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/UnitWrapMod.o f90_src/UnitWrapMod.F90 ${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesHydroWTFMod.o ../../biogeophys/FatesHydroWTFMod.F90 diff --git a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 b/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 deleted file mode 100644 index 3340c7bb0b..0000000000 --- a/functional_unit_testing/hydro/f90_src/EDParamsHydroMod.F90 +++ /dev/null @@ -1,61 +0,0 @@ - -! THIS IS A STRIPPED DOWN VERSION OF main/EDParamsMod.F90 - - -module EDParamsMod - ! - ! module that deals with reading the ED parameter file - ! - use iso_c_binding, only : c_char - use iso_c_binding, only : c_int - use FatesConstantsMod, only : r8 => fates_r8 - - implicit none - private - save - - integer(kind=c_int), parameter :: param_string_length = 32 - - ! Hydraulics Control Parameters - ! ---------------------------------------------------------------------------------------------- - real(r8),protected,public :: hydr_kmax_rsurf1 ! maximum conducitivity for unit root surface - ! soil to root direction (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf1 = "fates_hydr_kmax_rsurf1" - - real(r8),protected,public :: hydr_kmax_rsurf2 ! maximum conducitivity for unit root surface - ! root to soil direciton (kg water/m2 root area/Mpa/s) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_kmax_rsurf2 = "fates_hydr_kmax_rsurf2" - - real(r8),protected,public :: hydr_psi0 ! sapwood water potential at saturation (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psi0 = "fates_hydr_psi0" - - real(r8),protected,public :: hydr_psicap ! sapwood water potential at which capillary reserves exhausted (MPa) - character(kind=c_char,len=param_string_length),parameter,public :: hydr_name_psicap = "fates_hydr_psicap" - - public :: EDParamsPySet - -contains - - subroutine EDParamsPySet(rval,name) - - implicit none - ! Arguments - character(kind=c_char,len=*), intent(in) :: name - real(r8),intent(in) :: rval - - if(trim(name) == trim(hydr_name_psi0))then - hydr_psi0 = rval - elseif(trim(name) == trim(hydr_name_psicap))then - hydr_psicap = rval - else - print*,"ERROR in EDParamsPySet, uknown variable name: ",trim(name) - stop - end if - - return - end subroutine EDParamsPySet - - - - -end module EDParamsMod From 7f3d609adb1dfcd6b6fba4e76cd5502182924ace Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 Mar 2020 11:32:04 -0700 Subject: [PATCH 071/114] cleaning up volume calculations in hydro and initialization of recruits --- biogeophys/FatesPlantHydraulicsMod.F90 | 87 +++++++++++++++----------- 1 file changed, 51 insertions(+), 36 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5890c94814..500be766b0 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -494,7 +494,7 @@ subroutine InitTreeHydStates(site, cohort) end if !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) - h_aroot_mean = min(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:)) + h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:))) ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) ! the assumption is made here that initial conditions for soil water will @@ -782,7 +782,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) real(r8) :: fnrt_c ! Current amount of fine-root carbon in the plant [kg] real(r8) :: sapw_c ! Current amount of sapwood carbon in the plant [kg] real(r8) :: struct_c ! Current amount of structural carbon in the plant [kg] - real(r8) :: woody_bg_carb ! belowground woody biomass in carbon units [kgC/indiv] + real(r8) :: woody_bg_c ! belowground woody biomass in carbon units [kgC/indiv] real(r8) :: z_stem ! the height of the plants stem below crown [m] real(r8) :: sla ! specific leaf area [cm2/g] real(r8) :: v_aroot_tot ! total compartment volume of all absorbing roots for cohort [m3] @@ -790,15 +790,21 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] real(r8) :: a_sapwood ! sapwood area [m2] real(r8) :: a_sapwood_target ! sapwood cross-section area at reference height, at target biomass [m2] - real(r8) :: bsw_target ! sapwood carbon, at target [kgC] + real(r8) :: sapw_c_target ! sapwood carbon, at target [kgC] real(r8) :: v_sapwood ! sapwood volume [m3] real(r8) :: v_troot ! transporting root volume [m3/indiv] - real(r8) :: v_root ! Total (aroot+troot) root volume [m3/indiv] real(r8) :: rootfr ! mass fraction of roots in each layer [kg/kg] real(r8) :: crown_depth ! Depth of the plant's crown [m] real(r8) :: norm ! total root fraction used <1 integer :: nlevrhiz ! number of rhizosphere levels + + ! We allow the transporting root to donate a fraction of its volume to the absorbing + ! roots to help mitigate numerical issues due to very small volumes. This is the + ! fraction the transporting roots donate to those layers + real(r8), parameter :: t2aroot_vol_donate_frac = 0.65_r8 + + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft nlevrhiz = site_hydr%nlevrhiz @@ -823,32 +829,44 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 ! Leaf volumes - ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] - ccohort_hydr%v_ag(1:n_hypool_leaf) = leaf_c * EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + ! Note: We only update the leaf volume if there is leaf mass, thus preventing + ! us from calculating a zero volume. We do this because, in deciduous trees, + ! when they drop their leaves, we actually want to keep the leaf water they had + ! in stasis. So that when they reflush, there is water there to work with. But + ! if we zero out the comapartment when we flush, we have no way to conserve + ! that water. Until we have a better way to provide water on flushing, + ! we do this (rgk 03/20) + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] + ! Using rsnbl_math_prec here. Objective is to catch leaves that are in a dormant (off) state + ! but for any possible reason. If a leaf biomass is very close to zero, but not zero, we + ! will update the volume, which will force us to remove a lot of water, which will prevent + ! it from coming back in the wet season. Thus, we want to avoid any strange edge cases, and use + ! rsnbl_math_prec. + if(leaf_c>rsnbl_math_prec) then + ccohort_hydr%v_ag(1:n_hypool_leaf) = leaf_c * EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + end if ! Step sapwood volume ! ----------------------------------------------------------------------------------- - !BOC...may be needed for testing/comparison w/ v_sapwood - ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 + ! BOC...may be needed for testing/comparison w/ v_sapwood + ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 ! v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft) * kg_per_g * cm3_per_m3 ) ! calculate the sapwood cross-sectional area - call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,bsw_target) - a_sapwood = a_sapwood_target - - ! Alternative ways to calculate sapwood cross section - ! or .... - ! a_sapwood = a_sapwood_target * ccohort%bsw / bsw_target - ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(ft)*1.e-4_r8 - ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 - ! or ... + call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,sapw_c_target) + + ! uncomment this if you want to use + ! the actual sapwood, which may be lower than target due to branchfall. + a_sapwood = a_sapwood_target ! * sapw_c / sapw_c_target + + ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 call CrownDepth(ccohort%hite,crown_depth) z_stem = ccohort%hite - crown_depth - v_sapwood = a_sapwood * z_stem + v_sapwood = a_sapwood * z_stem ! + 0.333_r8*a_sapwood*crown_depth ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem @@ -856,9 +874,9 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) + woody_bg_c = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) - v_troot = b_woody_bg_carb * EDPftvarcon_inst%c2b(ft) / & + v_troot = woody_bg_c * EDPftvarcon_inst%c2b(ft) / & (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) @@ -873,13 +891,10 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * l_aroot_tot - ! Total amount of root volume - v_root = v_aroot_tot + v_troot - ! The transporting root donates some of its volume ! to the layer-by-layer absorbing root (which is now a hybrid compartment) - - ccohort_hydr%v_troot = 0.35 * v_root + ! ------------------------------------------------------------------------------ + ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer @@ -896,7 +911,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(0.65*v_root) + ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) end do @@ -942,13 +957,13 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! -- apply water mass conservation) do k=1,n_hypool_leaf - if( ccohort_hydr%v_ag(k) > nearzero) then - th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & - ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) - ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, pm_node(k)) - else - - end if + if( ccohort_hydr%v_ag(k) > nearzero ) then + th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & + ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) + ccohort_hydr%th_ag(k) = constrain_water_contents(th_ag_uncorr(k), small_theta_num, ft, pm_node(k)) + else + th_ag_uncorr(k) = ccohort_hydr%th_ag(k) + end if end do do k=n_hypool_leaf+1,n_hypool_ag @@ -1968,8 +1983,8 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) end subroutine updateSizeDepRhizHydStates - ! ==================================================================================== + subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) ! Arguments @@ -4281,8 +4296,8 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) end if if(abs(u(k))>nearzero)then rel_err = abs(err/u(k)) - if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. - (err /= err) )then + if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. & + (err /= err) )then write(fates_log(),*) 'Tri-diagonal solve produced solution with' write(fates_log(),*) 'non-negligable error.' write(fates_log(),*) 'Compartment: ',k From 9d85e03ee72ccb5fa4f4da002f70eed8626f44ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 24 Mar 2020 14:10:21 -0700 Subject: [PATCH 072/114] Updated hydro volume calculations to leaf-less plants --- biogeophys/FatesPlantHydraulicsMod.F90 | 47 +++++++++++++++++--------- 1 file changed, 31 insertions(+), 16 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 500be766b0..44966286d1 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -53,6 +53,7 @@ module FatesPlantHydraulicsMod use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : AREA_INV use EDTypesMod , only : AREA + use EDTypesMod , only : leaves_on use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : bc_out_type @@ -61,6 +62,7 @@ module FatesPlantHydraulicsMod use FatesInterfaceMod , only : numpft use FatesInterfaceMod , only : nlevsclass + use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth use FatesAllometryMod , only : set_root_fraction @@ -779,6 +781,7 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr real(r8) :: leaf_c ! Current amount of leaf carbon in the plant [kg] + real(r8) :: leaf_c_target ! Target leaf carbon (with some conditions) [kgC] real(r8) :: fnrt_c ! Current amount of fine-root carbon in the plant [kg] real(r8) :: sapw_c ! Current amount of sapwood carbon in the plant [kg] real(r8) :: struct_c ! Current amount of structural carbon in the plant [kg] @@ -803,8 +806,12 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) ! roots to help mitigate numerical issues due to very small volumes. This is the ! fraction the transporting roots donate to those layers real(r8), parameter :: t2aroot_vol_donate_frac = 0.65_r8 - + real(r8), parameter :: min_leaf_frac = 0.1_r8 ! Fraction of maximum leaf carbon that + ! we set as our lower cap on leaf volume + real(r8), parameter :: min_trim = 0.1_r8 ! The lower cap on trimming function used + ! to estimate maximum leaf carbon + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft nlevrhiz = site_hydr%nlevrhiz @@ -829,24 +836,32 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 ! Leaf volumes - ! Note: We only update the leaf volume if there is leaf mass, thus preventing - ! us from calculating a zero volume. We do this because, in deciduous trees, - ! when they drop their leaves, we actually want to keep the leaf water they had - ! in stasis. So that when they reflush, there is water there to work with. But - ! if we zero out the comapartment when we flush, we have no way to conserve - ! that water. Until we have a better way to provide water on flushing, - ! we do this (rgk 03/20) + ! Note: Leaf volumes of zero is problematic for two reasons. Zero volumes create + ! numerical difficulties, and they could also create problems when a leaf is trying + ! to re-flush. + ! Therefore, if the leaf is in an "off" status, then we do not update the leaf + ! volume. This way the volume is where it was when it dropped, and this is consistent + ! with the theory that leaf water potentials drive growth and re-flushing, not the + ! other way around. However, it is possible that we may have recruits with an + ! "off" status (due to external seed rain active during a dry or cold season). If a + ! cohort is newly created, we must give it a starting volume. + ! We also place a lower bound on how low the leaf volume is allowed to go, which is 10% + ! of the plant's carrying capacity. + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] - ! Using rsnbl_math_prec here. Objective is to catch leaves that are in a dormant (off) state - ! but for any possible reason. If a leaf biomass is very close to zero, but not zero, we - ! will update the volume, which will force us to remove a lot of water, which will prevent - ! it from coming back in the wet season. Thus, we want to avoid any strange edge cases, and use - ! rsnbl_math_prec. - if(leaf_c>rsnbl_math_prec) then - ccohort_hydr%v_ag(1:n_hypool_leaf) = leaf_c * EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) - end if + + ! Get the target, or rather, maximum leaf carrying capacity of plant + ! Lets also avoid super-low targets that have very low trimming functions + + call bleaf(ccohort%dbh,ccohort%pft,max(ccohort%canopy_trim,min_trim),leaf_c_target) + + if( (ccohort%status_coh == leaves_on) .or. ccohort_hydr%is_newly_recruited ) then + ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & + EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + end if + ! Step sapwood volume ! ----------------------------------------------------------------------------------- From bf5f446d51396081edca3d4d0df75e53039abb43 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 25 Mar 2020 21:28:32 -0700 Subject: [PATCH 073/114] added capability in modify_fates_paramfile to change pft names and index by pft names --- tools/modify_fates_paramfile.py | 58 ++++++++++++++++++++++++--------- 1 file changed, 43 insertions(+), 15 deletions(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index c3cfa649fb..0635cfdb93 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -36,7 +36,8 @@ def main(): parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') # parser.add_argument('--var','--variable', dest='varname', type=str, help="What variable to modify? Required.", required=True) - parser.add_argument('--pft','--PFT', dest='pftnum', type=int, help="PFT number to modify. If this is missing and --allPFTs is not specified, will assume a global variable.") + parser.add_argument('--pft','--PFT', dest='pftnum', type=int, help="PFT number to modify. If this and --pftname are missing and --allPFTs is not specified, will assume a global variable.") + parser.add_argument('--pftname', '--PFTname', dest='pftname', type=str, help="Name of PFT to modify. alternate argument to --pft or --allpfts") parser.add_argument('--allPFTs', '--allpfts', dest='allpfts', help="apply to all PFT indices. Cannot use at same time as --pft argument.", action="store_true") parser.add_argument('--fin', '--input', dest='inputfname', type=str, help="Input filename. Required.", required=True) parser.add_argument('--fout','--output', dest='outputfname', type=str, help="Output filename. Required.", required=True) @@ -52,6 +53,7 @@ def main(): tempdir = tempfile.mkdtemp() tempfilename = os.path.join(tempdir, 'temp_fates_param_file.nc') ncfile_old = None + rename_pft = False # try: outputval = float(args.val) @@ -64,7 +66,11 @@ def main(): if len(outputval) == 0: raise RuntimeError('output variable needs to have size greater than zero') except: - raise RuntimeError('output variable not interpretable as real or array') + if args.varname != 'fates_pftname': + raise RuntimeError('output variable not interpretable as real or array') + else: + print(args.val) + rename_pft = True # # try: @@ -90,6 +96,10 @@ def main(): otherdimpresent = True otherdimname = var.dimensions[i] otherdimlength = var.shape[i] + elif var.dimensions[i] == 'fates_string_length' and rename_pft: + otherdimpresent = True + otherdimname = var.dimensions[i] + otherdimlength = var.shape[i] else: raise ValueError('variable is not on either the PFT or scalar dimension') # @@ -168,23 +178,41 @@ def main(): # declare as none for now ncfile_old = None # - if (args.pftnum == None and ispftvar) and not args.allpfts: + if (args.pftnum == None and args.pftname == None and ispftvar) and not args.allpfts: raise ValueError('pft value is missing but variable has pft dimension.') - if (args.pftnum != None) and args.allpfts: + if (args.pftnum != None or args.pftname != None) and args.allpfts: raise ValueError("can't specify both a PFT number and the argument allPFTs.") - if args.pftnum != None and not ispftvar: + if (args.pftnum != None or args.pftname != None) and not ispftvar: raise ValueError('pft value is present but variable does not have pft dimension.') + if (args.pftnum != None and args.pftname != None): + raise ValueError('can only specify pft number or name, not both.') + if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: + ## now we need to figure out what the number of the pft that has been given a name argument + print(args.pftname) + pftnamelist = [] + npftnames = ncfile.variables['fates_pftname'].shape[0] + for i in range(npftnames): + pftnamelist.append(''.join((ncfile.variables['fates_pftname'][i,:]).tolist()).strip()) + n_times_pft_listed = pftnamelist.count(args.pftname.strip()) + if n_times_pft_listed != 1: + raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') + pftnum = pftnamelist.index(args.pftname.strip()) + args.pftnum=pftnum +1 if args.pftnum != None and ispftvar: - if args.pftnum > npft_file: - raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') - if pftdim == 0: - if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) - var[args.pftnum-1] = outputval - if pftdim == 1: - if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) - var[:,args.pftnum-1] = outputval + if not rename_pft: + if args.pftnum > npft_file: + raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') + if pftdim == 0: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) + var[args.pftnum-1] = outputval + if pftdim == 1: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) + var[:,args.pftnum-1] = outputval + else: + print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join((ncfile.variables['fates_pftname'][args.pftnum-1,:]).tolist()).strip()+'", with new value of "'+args.val+'"') + var[args.pftnum-1] = args.val elif args.allpfts and ispftvar: if pftdim == 0: if not args.silent: From 82d20dbe699008a9dd03f4f65a33e629ff327fc0 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 26 Mar 2020 13:05:05 -0700 Subject: [PATCH 074/114] removed unnecessary print statement --- tools/modify_fates_paramfile.py | 1 - 1 file changed, 1 deletion(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 0635cfdb93..8a4e5b3dc5 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -69,7 +69,6 @@ def main(): if args.varname != 'fates_pftname': raise RuntimeError('output variable not interpretable as real or array') else: - print(args.val) rename_pft = True # # From 2ec0b7b4d0218fbfe673fd888459afe5c4ab0b89 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Thu, 26 Mar 2020 20:52:14 -0700 Subject: [PATCH 075/114] removed another unneeded print statement --- tools/modify_fates_paramfile.py | 1 - 1 file changed, 1 deletion(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index ca3722e391..fefcd8fb6d 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -187,7 +187,6 @@ def main(): raise ValueError('can only specify pft number or name, not both.') if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: ## now we need to figure out what the number of the pft that has been given a name argument - print(args.pftname) pftnamelist = [] npftnames = ncfile.variables['fates_pftname'].shape[0] for i in range(npftnames): From 8311b91d566f55e59d1a28218aef1ce1b7351709 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 27 Mar 2020 18:37:01 -0600 Subject: [PATCH 076/114] updated to work with python 3's feature of treating netcdf metadata as bytes rather than strings --- tools/modify_fates_paramfile.py | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index fefcd8fb6d..12fb552cdc 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -190,7 +190,9 @@ def main(): pftnamelist = [] npftnames = ncfile.variables['fates_pftname'].shape[0] for i in range(npftnames): - pftnamelist.append(''.join((ncfile.variables['fates_pftname'][i,:]).tolist()).strip()) + pftname_bytelist = list(ncfile.variables['fates_pftname'][i,:]) + pftname_stringlist = [i.decode('utf-8') for i in pftname_bytelist] + pftnamelist.append(''.join(pftname_stringlist).strip()) n_times_pft_listed = pftnamelist.count(args.pftname.strip()) if n_times_pft_listed != 1: raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') @@ -209,8 +211,10 @@ def main(): print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) var[:,args.pftnum-1] = outputval else: - print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join((ncfile.variables['fates_pftname'][args.pftnum-1,:]).tolist()).strip()+'", with new value of "'+args.val+'"') - var[args.pftnum-1] = args.val + pftname_in_bytelist = list(ncfile.variables['fates_pftname'][args.pftnum-1,:]) + pftname_in_stringlist = [i.decode('utf-8') for i in pftname_in_bytelist] + print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join(pftname_in_stringlist).strip()+'", with new value of "'+args.val+'"') + var[args.pftnum-1] = args.val.ljust(otherdimlength) elif args.allpfts and ispftvar: if pftdim == 0: if not args.silent: @@ -243,7 +247,7 @@ def main(): actionstring = 'modify_fates_paramfile.py '+' '.join(sys.argv[1:]) timestampstring = datetime.datetime.fromtimestamp(time.time()).strftime('%a %b %d %Y, %H:%M:%S') # - oldhiststr = ncfile.history + oldhiststr = ncfile.history.decode('utf-8') newhiststr = oldhiststr + "\n "+timestampstring + ': ' + actionstring ncfile.history = newhiststr # From 7ade9b4c9cee433a561c91959eb46867245d6921 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Apr 2020 11:42:37 -0700 Subject: [PATCH 077/114] FATES-hydro: fixed solute and pressure psi equations to use a volumetric residual WC in conjunction with rwc at full turger --- biogeophys/FatesHydroWTFMod.F90 | 80 +++++++++++++++--------- parameter_files/fates_params_default.cdl | 18 +++--- 2 files changed, 58 insertions(+), 40 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 219cad3aba..dae73ab414 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -31,8 +31,8 @@ module FatesHydroWTFMod real(r8), parameter :: min_ftc = 0.0005_r8 ! Minimum allowed fraction of total conductance - real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation above this saturated frac - real(r8), parameter :: max_sf_interp = 0.95 ! Linear interpolation below this saturated frac + real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation below this saturated frac + real(r8), parameter :: max_sf_interp = 0.95 ! Linear interpolation above this saturated frac real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region @@ -148,7 +148,7 @@ module FatesHydroWTFMod real(r8) :: th_res ! Residual volumentric water content [m3/m3] real(r8) :: pinot ! osmotic potential at full turger [MPa] real(r8) :: epsil ! bulk elastic modulus [MPa] - real(r8) :: rwc_fd ! total RWC @ which elastic drainage begins [-] + real(r8) :: rwc_ft ! RWC @ full turgor, (elastic drainage begins)[-] real(r8) :: cap_corr ! correction for nonzero psi0x real(r8) :: cap_int ! intercept of capillary region of curve real(r8) :: cap_slp ! slope of capillary region of curve @@ -652,7 +652,7 @@ subroutine set_wrf_param_tfs(this,params_in) this%th_res = params_in(2) this%pinot = params_in(3) this%epsil = params_in(4) - this%rwc_fd = params_in(5) + this%rwc_ft = params_in(5) this%cap_corr = params_in(6) this%cap_int = params_in(7) this%cap_slp = params_in(8) @@ -758,8 +758,8 @@ function psi_from_th_tfs(this,th) result(psi) ! the elastic and capilary, and then smooth their ! combined with the caviation - call solutepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,psi_sol) - call pressurepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) + call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) psi_elastic = psi_sol + psi_press @@ -836,11 +836,11 @@ function dpsidth_from_th_tfs(this,th) result(dpsidth) ! the elastic and capilary, and then smooth their ! combined with the caviation - call solutepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,psi_sol) - call pressurepsi(th_corr,this%rwc_fd,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) + call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) - call dsolutepsidth(th,this%th_sat,this%th_res,this%rwc_fd,this%pinot,dsol_dth) - call dpressurepsidth(this%th_sat,this%th_res,this%rwc_fd,this%epsil,dpress_dth) + call dsolutepsidth(th,this%th_sat,this%th_res,this%rwc_ft,this%pinot,dsol_dth) + call dpressurepsidth(this%th_sat,this%th_res,this%rwc_ft,this%epsil,dpress_dth) delast_dth = dsol_dth + dpress_dth psi_elastic = psi_sol + psi_press @@ -938,9 +938,9 @@ function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) end function dftcdpsi_from_psi_tfs - !-------------------------------------------------------------------------------! + ! ===================================================================================== - subroutine solutepsi(th,rwc_fd,th_sat,th_res,pinot,psi) + subroutine solutepsi(th,rwc_ft,th_sat,th_res,pinot,psi) ! ! !DESCRIPTION: computes solute water potential (negative) as a function of ! water content for the plant PV curve. @@ -950,20 +950,32 @@ subroutine solutepsi(th,rwc_fd,th_sat,th_res,pinot,psi) ! !ARGUMENTS real(r8) , intent(in) :: th ! vol wc [m3 m-3] - real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: rwc_ft real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res real(r8) , intent(in) :: pinot real(r8) , intent(out) :: psi ! water potential [MPa] - psi = pinot*th_sat*(rwc_fd - th_res) / (th - th_sat*th_res) + ! ----------------------------------------------------------------------------------- + ! From eq 8, Christopherson et al: + ! + ! psi = pino/RWC*, where RWC*=(rwc-rwc_res)/(rwc_ft-rwc_res) + ! psi = pino * (rwc_ft-rwc_res)/(rwc-rwc_res) + ! + ! if rwc_res = th_res/th_sat + ! + ! = pino * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) + ! = pino * (th_sat*rwc_ft - th_res)/(th - th_res) + ! ----------------------------------------------------------------------------------- + + psi = pinot * (th_sat*rwc_ft - th_res) / (th - th_res) return end subroutine solutepsi - !-------------------------------------------------------------------------------! + ! ==================================================================================== - subroutine dsolutepsidth(th,th_sat,th_res,rwc_fd,pinot,dpsi_dth) + subroutine dsolutepsidth(th,th_sat,th_res,rwc_ft,pinot,dpsi_dth) ! ! !DESCRIPTION: returns derivative of solutepsi() wrt theta @@ -974,18 +986,24 @@ subroutine dsolutepsidth(th,th_sat,th_res,rwc_fd,pinot,dpsi_dth) real(r8) , intent(in) :: th real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res - real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: rwc_ft real(r8) , intent(in) :: pinot real(r8) , intent(out) :: dpsi_dth - dpsi_dth = -1._r8*th_sat*pinot*(rwc_fd - th_res )/((th - th_sat*th_res)**2._r8) + ! ----------------------------------------------------------------------------------- + ! Take derivative of eq 8 (function solutepsi) + ! psi = pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-1 + ! dpsi_dth = -pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-2 + ! ----------------------------------------------------------------------------------- + + dpsi_dth = -1._r8*pinot*(th_sat*rwc_ft - th_res )*(th - th_res)**(-2._r8) return end subroutine dsolutepsidth - !-------------------------------------------------------------------------------! + ! ===================================================================================== - subroutine pressurepsi(th,rwc_fd,th_sat,th_res,pinot,epsil,psi) + subroutine pressurepsi(th,rwc_ft,th_sat,th_res,pinot,epsil,psi) ! ! !DESCRIPTION: computes pressure water potential (positive) as a function of ! water content for the plant PV curve. @@ -994,22 +1012,22 @@ subroutine pressurepsi(th,rwc_fd,th_sat,th_res,pinot,epsil,psi) ! ! !ARGUMENTS real(r8) , intent(in) :: th - real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: rwc_ft real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res real(r8) , intent(in) :: pinot real(r8) , intent(in) :: epsil real(r8) , intent(out) :: psi ! water potential [MPa] - - psi = epsil * (th - th_sat*rwc_fd) / (th_sat*(rwc_fd-th_res)) - pinot + psi = epsil * (th - th_sat*rwc_ft) / (th_sat*rwc_ft-th_res) - pinot return end subroutine pressurepsi - !-------------------------------------------------------------------------------! - subroutine dpressurepsidth(th_sat,th_res,rwc_fd,epsil,dpsi_dth) + ! ===================================================================================== + + subroutine dpressurepsidth(th_sat,th_res,rwc_ft,epsil,dpsi_dth) ! ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta ! @@ -1018,16 +1036,16 @@ subroutine dpressurepsidth(th_sat,th_res,rwc_fd,epsil,dpsi_dth) ! !ARGUMENTS real(r8) , intent(in) :: th_sat real(r8) , intent(in) :: th_res - real(r8) , intent(in) :: rwc_fd + real(r8) , intent(in) :: rwc_ft real(r8) , intent(in) :: epsil real(r8) , intent(out) :: dpsi_dth ! derivative of water potential wrt theta [MPa m3 m-3] - dpsi_dth = epsil/(th_sat*(rwc_fd - th_res)) + dpsi_dth = epsil/(th_sat*rwc_ft - th_res) return end subroutine dpressurepsidth - !-------------------------------------------------------------------------------! + ! ===================================================================================== subroutine capillarypsi(th,th_sat,cap_int,cap_slp,psi) ! @@ -1047,7 +1065,7 @@ subroutine capillarypsi(th,th_sat,cap_int,cap_slp,psi) return end subroutine capillarypsi - !-------------------------------------------------------------------------------! + ! ===================================================================================== subroutine dcapillarypsidth(cap_slp,th_sat,y) ! @@ -1065,8 +1083,8 @@ subroutine dcapillarypsidth(cap_slp,th_sat,y) return end subroutine dcapillarypsidth - ! ------------------------------------------------------------------------------------- - + ! ===================================================================================== + subroutine bisect_pv(this,lower, upper, psi, th) ! ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index e3782c292d..d275d73573 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -199,7 +199,7 @@ variables: fates_hydr_epsil_node:long_name = "bulk elastic modulus" ; double fates_hydr_fcap_node(fates_hydr_organs, fates_pft) ; fates_hydr_fcap_node:units = "unitless" ; - fates_hydr_fcap_node:long_name = "fraction of (1-resid_node) that is capillary in source" ; + fates_hydr_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; fates_hydr_kmax_node:units = "kg/MPa/m/s" ; fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; @@ -219,8 +219,8 @@ variables: fates_hydr_pitlp_node:units = "MPa" ; fates_hydr_pitlp_node:long_name = "turgor loss point" ; double fates_hydr_resid_node(fates_hydr_organs, fates_pft) ; - fates_hydr_resid_node:units = "fraction" ; - fates_hydr_resid_node:long_name = "residual fraction" ; + fates_hydr_resid_node:units = "cm3/cm3" ; + fates_hydr_resid_node:long_name = "residual water conent" ; double fates_hydr_rfrac_stem(fates_pft) ; fates_hydr_rfrac_stem:units = "fraction" ; fates_hydr_rfrac_stem:long_name = "fraction of total tree resistance from troot to canopy" ; @@ -901,12 +901,12 @@ data: -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2, -1.2 ; fates_hydr_resid_node = - 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, - 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, - 0.325, 0.325, - 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, 0.325, - 0.325, 0.325, - 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15 ; + 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.21, + 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, + 0.21, 0.21, + 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11 ; fates_hydr_rfrac_stem = 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625 ; From be3569f393c652a9e8cf3d489b352798f1bd4a4a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Apr 2020 12:08:20 -0700 Subject: [PATCH 078/114] fates-hydro: updated routine names to use plant instead of tree, and to use CamelCase style. --- biogeochem/EDCohortDynamicsMod.F90 | 16 +++---- biogeophys/FatesPlantHydraulicsMod.F90 | 66 +++++++++++++------------- main/EDMainMod.F90 | 18 +++---- main/FatesRestartInterfaceMod.F90 | 4 +- 4 files changed, 52 insertions(+), 52 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index b8ecd8d510..b26534e9c7 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -40,13 +40,13 @@ module EDCohortDynamicsMod use FatesInterfaceMod , only : hlm_parteh_mode use FatesPlantHydraulicsMod, only : FuseCohortHydraulics use FatesPlantHydraulicsMod, only : CopyCohortHydraulics - use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps - use FatesPlantHydraulicsMod, only : InitTreeHydStates + use FatesPlantHydraulicsMod, only : UpdateSizeDepPlantHydProps + use FatesPlantHydraulicsMod, only : InitPlantHydStates use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesPlantHydraulicsMod, only : DeallocateHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage - use FatesPlantHydraulicsMod, only : UpdateTreeHydrNodes - use FatesPlantHydraulicsMod, only : UpdateTreeHydrLenVol + use FatesPlantHydraulicsMod, only : UpdatePlantHydrNodes + use FatesPlantHydraulicsMod, only : UpdatePlantHydrLenVol use FatesPlantHydraulicsMod, only : UpdatePlantKmax use FatesPlantHydraulicsMod, only : SavePreviousCompartmentVolumes use FatesPlantHydraulicsMod, only : ConstrainRecruitNumber @@ -293,11 +293,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & call InitHydrCohort(currentSite,new_cohort) ! This calculates node heights - call UpdateTreeHydrNodes(new_cohort%co_hydr,new_cohort%pft, & + call UpdatePlantHydrNodes(new_cohort%co_hydr,new_cohort%pft, & new_cohort%hite,currentSite%si_hydr) ! This calculates volumes and lengths - call UpdateTreeHydrLenVol(new_cohort,currentSite%si_hydr) + call UpdatePlantHydrLenVol(new_cohort,currentSite%si_hydr) ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr) @@ -308,7 +308,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, & ! This comes up with starter suctions and then water contents ! based on the soil values - call InitTreeHydStates(currentSite,new_cohort) + call InitPlantHydStates(currentSite,new_cohort) if(recruitstatus==1)then @@ -1322,7 +1322,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & currentCohort%vcmax25top ) - call updateSizeDepTreeHydProps(currentSite,currentCohort, bc_in) + call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) endif call DeallocateCohort(nextc) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 44966286d1..f3a90669df 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -222,17 +222,17 @@ module FatesPlantHydraulicsMod public :: UpdateH2OVeg public :: CopyCohortHydraulics public :: FuseCohortHydraulics - public :: updateSizeDepTreeHydProps - public :: updateSizeDepTreeHydStates - public :: UpdateTreePsiFTCFromTheta - public :: InitTreeHydStates - public :: updateSizeDepRhizHydProps - public :: updateSizeDepRhizHydStates + public :: UpdateSizeDepPlantHydProps + public :: UpdateSizeDepPlantHydStates + public :: UpdatePlantPsiFTCFromTheta + public :: InitPlantHydStates + public :: UpdateSizeDepRhizHydProps + public :: UpdateSizeDepRhizHydStates public :: RestartHydrStates public :: SavePreviousCompartmentVolumes public :: SavePreviousRhizVolumes - public :: UpdateTreeHydrNodes - public :: UpdateTreeHydrLenVol + public :: UpdatePlantHydrNodes + public :: UpdatePlantHydrLenVol public :: UpdatePlantKmax public :: ConstrainRecruitNumber public :: InitHydroGlobals @@ -325,11 +325,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ccohort_hydr => ccohort%co_hydr ! This calculates node heights - call UpdateTreeHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & + call UpdatePlantHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & sites(s)%si_hydr) ! This calculates volumes and lengths - call UpdateTreeHydrLenVol(ccohort,csite_hydr) + call UpdatePlantHydrLenVol(ccohort,csite_hydr) ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(ccohort_hydr,ccohort,sites(s)%si_hydr) @@ -426,7 +426,7 @@ end subroutine RestartHydrStates ! ==================================================================================== - subroutine InitTreeHydStates(site, cohort) + subroutine InitPlantHydStates(site, cohort) ! REQUIRED INPUTS: ! @@ -564,11 +564,11 @@ subroutine InitTreeHydStates(site, cohort) - end subroutine InitTreeHydStates + end subroutine InitPlantHydStates ! ===================================================================================== - subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) + subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) ! This subroutine updates the potential and the fractional ! of total conductivity based on the relative water @@ -611,13 +611,13 @@ subroutine UpdateTreePsiFTCFromTheta(ccohort,csite_hydr) end do return - end subroutine UpdateTreePsiFTCFromTheta + end subroutine UpdatePlantPsiFTCFromTheta ! ===================================================================================== - subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) + subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! This subroutine calculates the nodal heights critical to hydraulics in the plant @@ -689,7 +689,7 @@ subroutine UpdateTreeHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ccohort_hydr%z_node_troot = -z_cumul_rf return - end subroutine UpdateTreeHydrNodes + end subroutine UpdatePlantHydrNodes ! ===================================================================================== @@ -711,7 +711,7 @@ end subroutine SavePreviousCompartmentVolumes ! ===================================================================================== - subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) + subroutine UpdateSizeDepPlantHydProps(currentSite,ccohort,bc_in) ! DESCRIPTION: Updates absorbing root length (total and its vertical distribution) @@ -741,23 +741,23 @@ subroutine updateSizeDepTreeHydProps(currentSite,ccohort,bc_in) call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdateTreeHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) + call UpdatePlantHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment - ! volumes, and UpdateTreeHydrNodes is called prior to this. - call UpdateTreeHydrLenVol(ccohort,currentSite%si_hydr) + ! volumes, and UpdatePlantHydrNodes is called prior to this. + call UpdatePlantHydrLenVol(ccohort,currentSite%si_hydr) ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(ccohort_hydr,ccohort,currentsite%si_hydr) - end subroutine updateSizeDepTreeHydProps + end subroutine UpdateSizeDepPlantHydProps ! ===================================================================================== - subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) + subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! ----------------------------------------------------------------------------------- ! This subroutine calculates two attributes of a plant: @@ -931,11 +931,11 @@ subroutine UpdateTreeHydrLenVol(ccohort,site_hydr) end do return - end subroutine UpdateTreeHydrLenVol + end subroutine UpdatePlantHydrLenVol ! ===================================================================================== - subroutine updateSizeDepTreeHydStates(currentSite,ccohort) + subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ! ! !DESCRIPTION: ! @@ -964,7 +964,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) associate(pm_node => currentSite%si_hydr%pm_node) - ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first + ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) @@ -1017,7 +1017,7 @@ subroutine updateSizeDepTreeHydStates(currentSite,ccohort) ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 end associate - end subroutine updateSizeDepTreeHydStates + end subroutine UpdateSizeDepPlantHydStates ! ===================================================================================== @@ -1405,12 +1405,12 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) ! -------------------------------------------------------------------------------- ! All other ed_Hydr_site_type variables are initialized elsewhere: ! - ! init_patch() -> updateSizeDepRhizHydProps -> shellgeom() + ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() ! this%v_shell ! this%r_node_shell ! this%r_out_shell ! - ! init_patch() -> updateSizeDepRhizHydProps() + ! init_patch() -> UpdateSizeDepRhizHydProps() ! this%l_aroot_layer_init ! this%l_aroot_1D ! this%kmax_upper_shell @@ -1785,7 +1785,7 @@ end subroutine UpdateSizeDepRhizVolLenCon ! ===================================================================================== - subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) + subroutine UpdateSizeDepRhizHydProps(currentSite, bc_in ) ! ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. ! As fine root biomass (and thus absorbing root length) increases, this characteristic @@ -1811,11 +1811,11 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) return - end subroutine updateSizeDepRhizHydProps + end subroutine UpdateSizeDepRhizHydProps ! ================================================================================= - subroutine updateSizeDepRhizHydStates(currentSite, bc_in) + subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. ! As fine root biomass (and thus absorbing root length) increases, this characteristic @@ -1996,7 +1996,7 @@ subroutine updateSizeDepRhizHydStates(currentSite, bc_in) end if !nshell > 1 - end subroutine updateSizeDepRhizHydStates + end subroutine UpdateSizeDepRhizHydStates ! ==================================================================================== @@ -2468,7 +2468,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! of plant compartments ! --------------------------------------------------------- - call UpdateTreePsiFTCFromTheta(ccohort,site_hydr) + call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 2635ba0f37..aa6798653d 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -56,13 +56,13 @@ module EDMainMod use FatesConstantsMod , only : primaryforest, secondaryforest use FatesConstantsMod , only : nearzero use FatesPlantHydraulicsMod , only : do_growthrecruiteffects - use FatesPlantHydraulicsMod , only : updateSizeDepTreeHydProps - use FatesPlantHydraulicsMod , only : updateSizeDepTreeHydStates - use FatesPlantHydraulicsMod , only : initTreeHydStates - use FatesPlantHydraulicsMod , only : updateSizeDepRhizHydProps + use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydProps + use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydStates + use FatesPlantHydraulicsMod , only : InitPlantHydStates + use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai - use FatesPlantHydraulicsMod , only : updateSizeDepRhizHydStates + use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydStates use EDLoggingMortalityMod , only : IsItLoggingTime use FatesGlobals , only : endrun => fates_endrun use ChecksBalancesMod , only : SiteMassStock @@ -252,8 +252,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length ! density --> node radii and volumes) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then - call updateSizeDepRhizHydProps(currentSite, bc_in) - call updateSizeDepRhizHydStates(currentSite, bc_in) + call UpdateSizeDepRhizHydProps(currentSite, bc_in) + call UpdateSizeDepRhizHydStates(currentSite, bc_in) end if end if @@ -430,8 +430,8 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! (size --> heights of elements --> hydraulic path lengths --> ! maximum node-to-node conductances) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then - call updateSizeDepTreeHydProps(currentSite,currentCohort, bc_in) - call updateSizeDepTreeHydStates(currentSite,currentCohort) + call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) + call UpdateSizeDepPlantHydStates(currentSite,currentCohort) end if currentCohort => currentCohort%taller diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 371380ebcf..b00a5a8cea 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -24,7 +24,7 @@ module FatesRestartInterfaceMod use FatesHydraulicsMemMod, only : n_hypool_ag use FatesHydraulicsMemMod, only : n_hypool_troot use FatesHydraulicsMemMod, only : nlevsoi_hyd_max - use FatesPlantHydraulicsMod, only : UpdateTreePsiFTCFromTheta + use FatesPlantHydraulicsMod, only : UpdatePlantPsiFTCFromTheta use PRTGenericMod, only : prt_global use EDCohortDynamicsMod, only : nan_cohort use EDCohortDynamicsMod, only : zero_cohort @@ -2412,7 +2412,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) - call UpdateTreePsiFTCFromTheta(ccohort,sites(s)%si_hydr) + call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) ccohort%co_hydr%errh2o_growturn_aroot = & From 78ad5c543d065b7ae8e294b64c4af58cddacb101 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 17 Apr 2020 12:51:04 -0700 Subject: [PATCH 079/114] fates-hydro: resolved syntax issues from review, fixed constrain water contents to use volumetric residual --- biogeophys/FatesHydroWTFMod.F90 | 37 +++++++++++++++++--------- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 2 files changed, 26 insertions(+), 13 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index dae73ab414..acae6e3e41 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -30,6 +30,9 @@ module FatesHydroWTFMod real(r8), parameter :: min_ftc = 0.0005_r8 ! Minimum allowed fraction of total conductance + ! Bounds on saturated fraction, outside of which we use linear PV or stop flow + ! In this context, the saturated fraction is defined by the volumetric WC "th" + ! and the volumetric residual and saturation "th_res" and "th_sat": (th-th_r)/(th_sat-th_res) real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation below this saturated frac real(r8), parameter :: max_sf_interp = 0.95 ! Linear interpolation above this saturated frac @@ -294,7 +297,7 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: satfrac ! Saturated fraction [-] real(r8) :: th ! Volumetric Water Cont [m3/m3] - real(r8) :: psi_interp ! psi where we start lin interp + real(r8) :: psi_interp ! psi where we start lin interp [Mpa] real(r8) :: th_interp ! th where we start lin interp real(r8) :: dpsidth_interp ! change in psi during lin interp (slope) real(r8) :: m ! pore size distribution param (1/n) @@ -307,7 +310,7 @@ function th_from_psi_vg(this,psi) result(th) if(psi=0._r8) then dftcdpsi = 0._r8 @@ -473,14 +486,14 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) t1 = (this%alpha*psi_eff)**(this%psd-1._r8) dt1 = this%alpha*(this%psd-1._r8)*(this%alpha*psi_eff)**(this%psd-2._r8) - t2 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(1._r8/this%psd-1._r8) - dt2 = (1._r8/this%psd-1._r8) * & - (1._r8 + (this%alpha*psi_eff)**this%psd)**(1._r8/this%psd-2._r8) * & + t2 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(m-1._r8) + dt2 = (m-1._r8) * & + (1._r8 + (this%alpha*psi_eff)**this%psd)**(m-2._r8) * & this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha - t3 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*( 1._r8-1._r8/this%psd)) - dt3 = this%tort*(1._r8-1._r8/this%psd) * & - (1._r8 + (this%alpha*psi_eff)**this%psd )**(this%tort*(1._r8-1._r8/this%psd)-1._r8) * & + t3 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*( 1._r8-m)) + dt3 = this%tort*(1._r8-m) * & + (1._r8 + (this%alpha*psi_eff)**this%psd )**(this%tort*(1._r8-m)-1._r8) * & this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha dftcdpsi = 2._r8*(1._r8-t1*t2)*(t1*dt2 + t2*dt1)/t3 - & diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index f3a90669df..f09bff02e9 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1038,7 +1038,7 @@ function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) ! !------------------------------------------------------------------------ ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) - thr = ths * EDPftvarcon_inst%hydr_resid_node(ft,pm_type) + thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) th_corr = max((thr+delta),min((ths-delta),th_uncorr)) return From 1796e92785af23c62838ed4a89cf9fa06380ac4b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 20 Apr 2020 10:01:53 -0700 Subject: [PATCH 080/114] Updated diagnostics for hydro --- biogeophys/FatesPlantHydraulicsMod.F90 | 142 +++++++++---- main/FatesHistoryInterfaceMod.F90 | 263 +++++++++++++++++-------- main/FatesHydraulicsMemMod.F90 | 20 +- 3 files changed, 296 insertions(+), 129 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index f09bff02e9..3775fb3893 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1179,10 +1179,6 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) -! ccohort_hydr%sapflow = (currentCohort%n*ccohort_hydr%sapflow + & -! nextCohort%n*ncohort_hydr%sapflow)/newn -! ccohort_hydr%rootuptake = (currentCohort%n*ccohort_hydr%rootuptake + & -! nextCohort%n*ncohort_hydr%rootuptake)/newn ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & nextCohort%n*ncohort_hydr%qtop)/newn @@ -2230,6 +2226,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) integer :: j_bc ! soil layer index for boundary conditions integer :: k ! 1D plant-soil continuum array integer :: ft ! plant functional type index + integer :: sz ! plant's size class index integer :: t ! previous timesteps (for lwp stability calculation) integer :: nstep !number of time steps @@ -2248,12 +2245,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! array of soil layer indices which have been ordered integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) - ! number of cohorts in this size-class/pft bin (nlevsclass,numpft) for averaging - integer,allocatable :: ncohorts_scpf(:,:) - ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] real(r8) :: kbg_layer(nlevsoi_hyd_max) - + real(r8) :: rootuptake(nlevsoi_hyd_max) ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/layer/step] real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] @@ -2266,8 +2260,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch - real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] - real(r8) :: rootuptake ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/step] + real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) logical :: recruitflag ! flag to check if there is newly recruited cohorts @@ -2275,9 +2268,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] + integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index - - ! ---------------------------------------------------------------------------------- ! Important note: We are interested in calculating the total fluxes in and out of the @@ -2293,24 +2285,30 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) !update water storage in veg after incorporating newly recuited cohorts if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) - ! This helps with diagnostics - allocate(ncohorts_scpf(nlevsclass,numpft)) - do s = 1, nsites site_hydr => sites(s)%si_hydr + nlevrhiz = site_hydr%nlevrhiz + ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN dth_layershell_col(:,:) = 0._r8 site_hydr%dwat_veg = 0._r8 site_hydr%errh2o_hyd = 0._r8 - ncohorts_scpf(:,:) = 0 prev_h2oveg = site_hydr%h2oveg prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV bc_out(s)%qflx_ro_sisl(:) = 0._r8 - site_hydr%sapflow(:,:) = 0._r8 + + ! Zero out diagnotsics that rely on accumulation + site_hydr%sapflow_scpf(:,:) = 0._r8 + site_hydr%rootuptake_sl(:) = 0._r8 + site_hydr%rootuptake0_scpf(:,:) = 0._r8 + site_hydr%rootuptake10_scpf(:,:) = 0._r8 + site_hydr%rootuptake50_scpf(:,:) = 0._r8 + site_hydr%rootuptake100_scpf(:,:) = 0._r8 + ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- @@ -2411,7 +2409,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call MatSolve2D(site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake,wb_err_plant,dwat_plant, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) else @@ -2436,7 +2434,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & - sapflow,rootuptake, & + sapflow,rootuptake(1:nlevrhiz), & wb_err_plant,dwat_plant, & dth_layershell_col) @@ -2456,12 +2454,30 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! (this is not zerod, but incremented) site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV - ! Sapflow diagnostic [kg/indiv/s] - ncohorts_scpf(ccohort%size_class,ft) = & - ncohorts_scpf(ccohort%size_class,ft) + 1 - site_hydr%sapflow(ccohort%size_class,ft) = & - site_hydr%sapflow(ccohort%size_class,ft) + sapflow/dtime + sc = ccohort%size_class + ! Sapflow diagnostic [kg/ha/s] + site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow/dtime + + ! Root uptake per rhiz layer [kg/ha/s] + site_hydr%rootuptake_sl(1:nlevrhiz) = site_hydr%rootuptake_sl(1:nlevrhiz) + & + rootuptake(1:nlevrhiz)*ccohort%n + + ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] + ! These are normalized by depth (in case the desired horizon extends + ! beyond the actual rhizosphere) + + site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n + + site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n + + site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n + + site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & + SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n ! --------------------------------------------------------- ! Update water potential and frac total conductivity @@ -2614,19 +2630,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err - do ft = 1, numpft - do sc = 1,nlevsclass - if(ncohorts_scpf(sc,ft)>0)then - site_hydr%sapflow(sc,ft) = & - site_hydr%sapflow(sc,ft) / real(ncohorts_scpf(sc,ft),r8) - end if - end do - end do - enddo !site - - deallocate(ncohorts_scpf) - + + return end subroutine Hydraulics_BC ! ===================================================================================== @@ -3016,7 +3022,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Arguments (OUT) real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] real(r8),intent(out) :: wb_err_plant ! total error from the plant, transpiration ! should match change in storage [kg] real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] @@ -3119,7 +3125,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! So we need to zero them, as they are incremented ! over the sub-steps sapflow = 0._r8 - rootuptake = 0._r8 + rootuptake(:) = 0._r8 ft = cohort%pft @@ -3602,7 +3608,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Add the current soil layer's contribution to total ! sap and root flux [kg] sapflow = sapflow + sapflow_lyr - rootuptake = rootuptake + rootuptake_lyr + rootuptake(ilayer) = rootuptake_lyr ! Record the layer with the most iterations, but only @@ -4374,7 +4380,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & real(r8),intent(in) :: tmx ! time interval to integrate over [s] real(r8),intent(in) :: qtop real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration @@ -4515,7 +4521,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ! The rootuptake is the integrated flux between the 1st rhizosphere ! and absorbing roots sapflow = 0._r8 - rootuptake = 0._r8 + rootuptake(:) = 0._r8 ! Chnage in water content, over all substeps [m3/m3] dth_node(:) = 0._r8 @@ -4990,7 +4996,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & do j = 1,site_hydr%nlevrhiz ! Connection betwen the 1st rhizosphere and absorbing roots icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 - rootuptake = rootuptake + q_flux(icnx_ar)*dtime + rootuptake(j) = q_flux(icnx_ar)*dtime enddo @@ -5046,6 +5052,58 @@ end subroutine MatSolve2D ! ===================================================================================== + function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) + + ! This function sums the quantity in array_in between depth_t (top) + ! and depth_b. It assumes many things. Firstly, that the depth coordinates + ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that + ! those coordinates are positive down. + + type(ed_site_hydr_type), intent(in) :: site_hydr + real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) + real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) + real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) + real(r8) :: depth_sum ! The summed result we return in units (/depth) + integer :: i_rhiz_t ! Layer index of top full layer + integer :: i_rhiz_b ! layer index of bottom full layer + integer :: nlevrhiz ! Number of rhizosphere layers (not shells) + real(r8) :: frac ! Fraction of partial layer, by depth + + i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then + return + end if + + ! Sum all fully encased layers + if(i_rhiz_b>=i_rhiz_t)then + depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) + end if + + ! Find fraction contribution from top partial layer (if any) + if(i_rhiz_t>1) then + frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) + depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) + end if + + ! Find fraction contribution from bottom partial layer (if any) + if(i_rhiz_b fates_endrun use EDTypesMod , only : nclmax @@ -254,6 +255,8 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_pheno_err_si integer :: ih_h2oveg_hydro_err_si + + integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si integer :: ih_gdd_si @@ -439,8 +442,7 @@ module FatesHistoryInterfaceMod integer :: ih_errh2o_scpf integer :: ih_tran_scpf -! integer :: ih_rootuptake_scpf -! integer :: ih_rootuptake_sl + ! integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension integer :: ih_sapflow_scpf integer :: ih_iterh1_scpf @@ -459,7 +461,26 @@ module FatesHistoryInterfaceMod integer :: ih_sflc_scpf integer :: ih_lflc_scpf integer :: ih_btran_scpf + + ! Hydro: Soil water states + integer :: ih_rootwgt_soilvwc_si + integer :: ih_rootwgt_soilvwcsat_si + integer :: ih_rootwgt_soilmatpot_si + + ! Hydro: Soil water state by layer + integer :: ih_soilmatpot_sl + integer :: ih_soilvwc_sl + integer :: ih_soilvwcsat_sl + + ! Hydro: Root water Uptake rates + integer :: ih_rootuptake_si + integer :: ih_rootuptake_sl + integer :: ih_rootuptake0_scpf + integer :: ih_rootuptake10_scpf + integer :: ih_rootuptake50_scpf + integer :: ih_rootuptake100_scpf + ! indices to (site x fuel class) variables integer :: ih_litter_moisture_si_fuel @@ -3374,7 +3395,7 @@ end subroutine update_history_prod ! ===================================================================================== - subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) + subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -3382,6 +3403,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) ! --------------------------------------------------------------------------------- use FatesHydraulicsMemMod, only : ed_cohort_hydr_type, nshell + use FatesHydraulicsMemMod, only : ed_site_hydr_type use EDTypesMod , only : maxpft @@ -3390,14 +3412,13 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) real(r8) , intent(in) :: dt_tstep ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array integer :: ipa ! The local "I"ndex of "PA"tches - integer :: io_pa ! The patch index of the IO array - integer :: io_pa1 ! The first patch index in the IO array for each site integer :: ft ! functional type index integer :: scpf ! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array @@ -3413,12 +3434,23 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) integer :: iscpf ! index of the scpf group integer :: ipft ! index of the pft loop integer :: iscls ! index of the size-class loop - integer :: j ! soil layer index integer :: k ! rhizosphere shell index - + integer :: jsoil ! soil layer index + integer :: jrhiz ! rhizosphere layer index + integer :: jr1, jr2 ! Rhizosphere top and bottom layers + integer :: nlevrhiz ! number of rhizosphere layers + real(r8) :: mean_soil_vwc ! mean soil volumetric water content [m3/m3] + real(r8) :: mean_soil_vwcsat ! mean soil saturated volumetric water content [m3/m3] + real(r8) :: mean_soil_matpot ! mean soil water potential [MPa] + real(r8) :: layer_areaweight ! root area weighting factor for each soil layer + real(r8) :: areaweight ! root area weighting factor for column + real(r8) :: vwc ! volumetric water content of layer [m3/m3] = theta + real(r8) :: vwc_sat ! saturated water content of layer [m3/m3] + real(r8) :: psi ! matric potential of soil layer type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: site_hydr real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? @@ -3428,9 +3460,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & -! hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & -! hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & -! hio_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%r82d, & hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & @@ -3450,25 +3479,76 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_h2oveg_si => this%hvars(ih_h2oveg_si)%r81d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & hio_nplant_si_capf => this%hvars(ih_nplant_si_capf)%r82d, & - hio_h2oveg_hydro_err_si => this%hvars(ih_h2oveg_hydro_err_si)%r81d ) - + hio_h2oveg_hydro_err_si => this%hvars(ih_h2oveg_hydro_err_si)%r81d, & + hio_rootwgt_soilvwc_si => this%hvars(ih_rootwgt_soilvwc_si)%r81d, & + hio_rootwgt_soilvwcsat_si => this%hvars(ih_rootwgt_soilvwcsat_si)%r81d, & + hio_rootwgt_soilmatpot_si => this%hvars(ih_rootwgt_soilmatpot_si)%r81d, & + hio_soilmatpot_sl => this%hvars(ih_soilmatpot_sl)%r82d, & + hio_soilvwc_sl => this%hvars(ih_soilvwc_sl)%r82d, & + hio_soilvwcsat_sl => this%hvars(ih_soilvwcsat_sl)%r82d, & + hio_rootuptake_si => this%hvars(ih_rootuptake_si)%r81d, & + hio_rootuptake_sl => this%hvars(ih_rootuptake_sl)%r82d, & + hio_rootuptake0_scpf => this%hvars(ih_rootuptake0_scpf)%r82d, & + hio_rootuptake10_scpf => this%hvars(ih_rootuptake10_scpf)%r82d, & + hio_rootuptake50_scpf => this%hvars(ih_rootuptake50_scpf)%r82d, & + hio_rootuptake100_scpf => this%hvars(ih_rootuptake100_scpf)%r82d ) + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) - + do s = 1,nsites - - io_si = this%iovar_map(nc)%site_index(s) - io_pa1 = this%iovar_map(nc)%patch1_index(s) - hio_h2oveg_si(io_si) = sites(s)%si_hydr%h2oveg - hio_h2oveg_hydro_err_si(io_si) = sites(s)%si_hydr%h2oveg_hydro_err + site_hydr => sites(s)%si_hydr + nlevrhiz = site_hydr%nlevrhiz + jr1 = site_hydr%i_rhiz_t + jr2 = site_hydr%i_rhiz_b + + io_si = this%iovar_map(nc)%site_index(s) + + hio_h2oveg_si(io_si) = site_hydr%h2oveg + hio_h2oveg_hydro_err_si(io_si) = site_hydr%h2oveg_hydro_err ncohort_scpf(:) = 0.0_r8 ! Counter for normalizing weighting ! factors for cohort mean propoerties ! This is actually used as a check ! on hio_nplant_si_scpf + + ! Get column means of some soil diagnostics, these are weighted + ! by the amount of fine-root surface area in each layer + ! -------------------------------------------------------------------- + + mean_soil_vwc = 0._r8 + mean_soil_matpot = 0._r8 + mean_soil_vwcsat = 0._r8 + areaweight = 0._r8 + + do jrhiz=1,nlevrhiz + + jsoil = jrhiz + jr1-1 + vwc = bc_in(s)%h2o_liqvol_sl(jsoil) + psi = site_hydr%wrf_soil(jrhiz)%p%psi_from_th(vwc) + vwc_sat = bc_in(s)%watsat_sl(jsoil) + layer_areaweight = site_hydr%l_aroot_layer(jrhiz)*pi_const*site_hydr%rs1(jrhiz)**2.0 + mean_soil_vwc = mean_soil_vwc + vwc*layer_areaweight + mean_soil_vwcsat = mean_soil_vwcsat + vwc_sat*layer_areaweight + mean_soil_matpot = mean_soil_matpot + psi*layer_areaweight + areaweight = areaweight + layer_areaweight + + hio_soilmatpot_sl(io_si,jsoil) = psi + hio_soilvwc_sl(io_si,jsoil) = vwc + hio_soilvwcsat_sl(io_si,jsoil) = vwc_sat + + end do + + hio_rootwgt_soilvwc_si(io_si) = mean_soil_vwc/areaweight + hio_rootwgt_soilvwcsat_si(io_si) = mean_soil_vwcsat/areaweight + hio_rootwgt_soilmatpot_si(io_si) = mean_soil_matpot/areaweight + + hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) + hio_rootuptake_sl(io_si,:) = 0._r8 + hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ccohort => cpatch%shortest @@ -3483,11 +3563,14 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) cpatch => cpatch%younger end do !patch loop - do ipft = 1, numpft do iscls = 1,nlevsclass iscpf = (ipft-1)*nlevsclass + iscls - hio_sapflow_scpf(io_si,iscpf) = sites(s)%si_hydr%sapflow(iscls, ipft) ! [kg/indiv/s] + hio_sapflow_scpf(io_si,iscpf) = site_hydr%sapflow_scpf(iscls, ipft) + hio_rootuptake0_scpf(io_si,iscpf) = site_hydr%rootuptake0_scpf(iscls,ipft) + hio_rootuptake10_scpf(io_si,iscpf) = site_hydr%rootuptake10_scpf(iscls,ipft) + hio_rootuptake50_scpf(io_si,iscpf) = site_hydr%rootuptake50_scpf(iscls,ipft) + hio_rootuptake100_scpf(io_si,iscpf) = site_hydr%rootuptake100_scpf(iscls,ipft) end do end do @@ -3495,8 +3578,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - io_pa = io_pa1 + ipa - ccohort => cpatch%shortest do while(associated(ccohort)) @@ -3528,16 +3609,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & (ccohort_hydr%qtop) * number_fraction_rate ! [kg/indiv/s] -! hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & -! sum(ccohort_hydr%rootuptake) * number_fraction_rate ! [kg/indiv/s] - -! do j=1,sites(s)%si_hydr%nlevsoi_hyd -! hio_rootuptake_sl(io_si,j) = hio_rootuptake_sl(io_si,j) + & -! ccohort_hydr%rootuptake(j) * number_fraction_rate ! [kg/indiv/s] -! end do - - - hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & ccohort_hydr%iterh1 * number_fraction ! [-] @@ -3599,16 +3670,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) cpatch => cpatch%younger end do !patch loop - ! THE "SHSL" ARRAY CAN VERY EASILY BE LARGER THAN THE SCAGPFT ARRAY - ! WHICH IT WAS USING AS A SURROGATE, DISABLING (RGK 02-2020) - ! io_shsl = 0 - ! do j=1,sites(s)%si_hydr%nlevrhiz - ! do k=1, nshell - ! io_shsl = io_shsl + 1 - ! hio_h2osoi_shsl(io_si,io_shsl) = sites(s)%si_hydr%h2osoi_liqvol_shell(j,k) - ! end do - ! end do - if(hlm_use_ed_st3.eq.ifalse) then do scpf=1,nlevsclass*numpft if( abs(hio_nplant_si_scpf(io_si, scpf)-ncohort_scpf(scpf)) > 1.0E-8_r8 ) then @@ -5231,113 +5292,147 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) -! call this%set_history_var(vname='FATES_ROOTUPTAKE_SCPF', units='kg/indiv/s', & -! long='mean individual root uptake rate', use_default='inactive', & -! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) - -! call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg/indiv/s', & -! long='mean individual root uptake rate per layer', use_default='inactive', & -! avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) - -! call this%set_history_var(vname='FATES_H2OSOI_COL_SHSL', units='m3/m3', & -! long='volumetric soil moisture by layer and shell', use_default='inactive', & -! avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2osoi_si_scagpft ) - - call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & + call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & long='individual sap flow rate', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) - call this%set_history_var(vname='FATES_ITERH1_COL_SCPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & long='number of outer iterations required to achieve tolerable water balance error', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) - call this%set_history_var(vname='FATES_ITERH2_COL_SCPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ITERH2_SCPF', units='count/indiv/step', & long='number of inner iterations required to achieve tolerable water balance error', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) - call this%set_history_var(vname='FATES_ATH_COL_SCPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_ATH_SCPF', units='m3 m-3', & long='absorbing root water content', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) - call this%set_history_var(vname='FATES_TTH_COL_SCPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_TTH_SCPF', units='m3 m-3', & long='transporting root water content', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) - call this%set_history_var(vname='FATES_STH_COL_SCPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_STH_SCPF', units='m3 m-3', & long='stem water contenet', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) - call this%set_history_var(vname='FATES_LTH_COL_SCPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_LTH_SCPF', units='m3 m-3', & long='leaf water content', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) - call this%set_history_var(vname='FATES_AWP_COL_SCPF', units='MPa', & + call this%set_history_var(vname='FATES_AWP_SCPF', units='MPa', & long='absorbing root water potential', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) - call this%set_history_var(vname='FATES_TWP_COL_SCPF', units='MPa', & + call this%set_history_var(vname='FATES_TWP_SCPF', units='MPa', & long='transporting root water potential', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) - call this%set_history_var(vname='FATES_SWP_COL_SCPF', units='MPa', & + call this%set_history_var(vname='FATES_SWP_SCPF', units='MPa', & long='stem water potential', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) - call this%set_history_var(vname='FATES_LWP_COL_SCPF', units='MPa', & + call this%set_history_var(vname='FATES_LWP_SCPF', units='MPa', & long='leaf water potential', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) - call this%set_history_var(vname='FATES_AFLC_COL_SCPF', units='fraction', & + call this%set_history_var(vname='FATES_AFLC_SCPF', units='fraction', & long='absorbing root fraction of condutivity', use_default='active', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_aflc_scpf ) - call this%set_history_var(vname='FATES_TFLC_COL_SCPF', units='fraction', & + call this%set_history_var(vname='FATES_TFLC_SCPF', units='fraction', & long='transporting root fraction of condutivity', use_default='active', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tflc_scpf ) - call this%set_history_var(vname='FATES_SFLC_COL_SCPF', units='fraction', & + call this%set_history_var(vname='FATES_SFLC_SCPF', units='fraction', & long='stem water fraction of condutivity', use_default='active', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sflc_scpf ) - call this%set_history_var(vname='FATES_LFLC_COL_SCPF', units='fraction', & + call this%set_history_var(vname='FATES_LFLC_SCPF', units='fraction', & long='leaf fraction of condutivity', use_default='active', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lflc_scpf ) - call this%set_history_var(vname='FATES_BTRAN_COL_SCPF', units='unitless', & + call this%set_history_var(vname='FATES_BTRAN_SCPF', units='unitless', & long='mean individual level btran', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) - -! call this%set_history_var(vname='FATES_SMATPOT_SISL', units='MPa', & -! long='mean soil water matric potenial by layer', use_default='inactive', & -! avgflag='A', vtype=site_layer_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) - -! call this%set_history_var(vname='FATES_LAROOT_COL_SCPF', units='kg/indiv/s', & -! long='Needs Description', use_default='active', & -! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & -! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_laroot_scpf) + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWC_SI', units='m3 m-3', & + long='soil volumetric water content, weighted by root area', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilvwc_si ) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWCSAT_SI', units='m3 m-3', & + long='soil saturated volumetric water content, weighted by root area', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilvwcsat_si ) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILMATPOT_SI', units='MPa', & + long='soil matric potential, weighted by root area', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilmatpot_si ) + + call this%set_history_var(vname='FATES_SOILMATPOT_SL', units='MPa', & + long='soil water matric potenial by soil layer', use_default='inactive', & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilmatpot_sl ) + + call this%set_history_var(vname='FATES_SOILVWC_SL', units='m3 m-3', & + long='soil volumetric water content by soil layer', use_default='inactive', & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilvwc_sl ) + + call this%set_history_var(vname='FATES_SOILVWCSAT_SL', units='m3 m-3', & + long='soil saturated volumetric water content by soil layer', use_default='inactive', & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilvwcsat_sl ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SI', units='kg ha-1 s-1', & + long='root water uptake rate', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_si ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg ha-1 s-1', & + long='root water uptake rate by soil layer', use_default='inactive', & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE0_SCPF', units='kg ha-1 m-1 s-1', & + long='root water uptake from 0 to to 10 cm depth, by plant size x pft ', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake0_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE10_SCPF', units='kg ha-1 m-1 s-1', & + long='root water uptake from 10 to to 50 cm depth, by plant size x pft ', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE50_SCPF', units='kg ha-1 m-1 s-1', & + long='root water uptake from 50 to to 100 cm depth, by plant size x pft ', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake50_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE100_SCPF', units='kg ha-1 m-1 s-1', & + long='root water uptake below 100 cm depth, by plant size x pft ', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake100_scpf ) call this%set_history_var(vname='H2OVEG', units = 'kg/m2', & long='water stored inside vegetation tissues (leaf, stem, roots)', use_default='inactive', & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index d693da4cea..9d5c18bfa5 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -144,12 +144,20 @@ module FatesHydraulicsMemMod ! Useful diagnostics ! ---------------------------------------------------------------------------------- - real(r8),allocatable :: sapflow(:,:) ! flow at base of tree (+ upward) [kg/indiv/s] + real(r8),allocatable :: sapflow_scpf(:,:) ! flow at base of tree (+ upward) [kg/ha/s] ! discretized by size x pft -!! real(r8),allocatable :: rootuptake(:) ! net flow into roots (+ into roots) [kg/cohort/s] + ! Root uptake per rhiz layer [kg/ha/s] + real(r8),allocatable :: rootuptake_sl(:) + ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] + ! These are normalized by depth (in case the desired horizon extends + ! beyond the actual rhizosphere) + real(r8), allocatable :: rootuptake0_scpf(:,:) ! 0-10 cm + real(r8), allocatable :: rootuptake10_scpf(:,:) ! 10-50 cm + real(r8), allocatable :: rootuptake50_scpf(:,:) ! 50-100 cm + real(r8), allocatable :: rootuptake100_scpf(:,:) ! 100+ cm @@ -404,7 +412,13 @@ subroutine InitHydrSite(this,numpft,numlevsclass) allocate(this%h2osoi_liq_prev(1:nlevrhiz)) ; this%h2osoi_liq_prev = nan allocate(this%rs1(1:nlevrhiz)); this%rs1(:) = fine_root_radius_const allocate(this%recruit_w_uptake(1:nlevrhiz)); this%recruit_w_uptake = nan - allocate(this%sapflow(1:numlevsclass,1:numpft)); this%sapflow = nan + + allocate(this%sapflow_scpf(1:numlevsclass,1:numpft)) ; this%sapflow_scpf = nan + allocate(this%rootuptake_sl(1:nlevrhiz)) ; this%rootuptake_sl = nan + allocate(this%rootuptake0_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake0_scpf = nan + allocate(this%rootuptake10_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake10_scpf = nan + allocate(this%rootuptake50_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake50_scpf = nan + allocate(this%rootuptake100_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake100_scpf = nan this%errh2o_hyd = nan this%dwat_veg = nan From b69586c8cb155a6457660554ff9000f5e88533f9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 20 Apr 2020 12:02:54 -0700 Subject: [PATCH 081/114] Fates hydro, tweaks on diagnostic units. --- biogeophys/FatesPlantHydraulicsMod.F90 | 19 ++++++++++--------- main/FatesHistoryInterfaceMod.F90 | 12 ++++++++++-- 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 3775fb3893..f926c64741 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -168,7 +168,7 @@ module FatesPlantHydraulicsMod ! is left between soil moisture and saturation [m3/m3] ! (if we are going to help purge super-saturation) - logical,parameter :: debug = .true. ! flag to report warning in hydro + logical,parameter :: debug = .false. ! flag to report warning in hydro character(len=*), parameter, private :: sourcefile = & @@ -2268,6 +2268,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] + real(r8) :: sumcheck ! used to debug mass balance in soil horizon diagnostics integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index @@ -2457,27 +2458,27 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) sc = ccohort%size_class ! Sapflow diagnostic [kg/ha/s] - site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow/dtime + site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/dtime ! Root uptake per rhiz layer [kg/ha/s] site_hydr%rootuptake_sl(1:nlevrhiz) = site_hydr%rootuptake_sl(1:nlevrhiz) + & - rootuptake(1:nlevrhiz)*ccohort%n + rootuptake(1:nlevrhiz)*ccohort%n/dtime ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] ! These are normalized by depth (in case the desired horizon extends ! beyond the actual rhizosphere) - + site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n + SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n - + SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n + SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n + SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime ! --------------------------------------------------------- ! Update water potential and frac total conductivity diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f46f4400ea..c6e426cecd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -445,6 +445,7 @@ module FatesHistoryInterfaceMod ! integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension integer :: ih_sapflow_scpf + integer :: ih_sapflow_si integer :: ih_iterh1_scpf integer :: ih_iterh2_scpf integer :: ih_supsub_scpf @@ -3461,6 +3462,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & + hio_sapflow_si => this%hvars(ih_sapflow_si)%r81d, & hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & @@ -3547,7 +3549,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) hio_rootuptake_sl(io_si,:) = 0._r8 hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) - + hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -5293,9 +5295,15 @@ subroutine define_history_vars(this, initialize_variables) upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & - long='individual sap flow rate', use_default='inactive', & + long='areal sap flow rate dimensioned by size x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) + + call this%set_history_var(vname='FATES_SAPFLOW_SI', units='kg/ha/s', & + long='areal sap flow rate', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_si ) + call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & long='number of outer iterations required to achieve tolerable water balance error', & From a1eac2b30f5e9b547db76843265c8a49e9558ee5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 21 Apr 2020 14:57:37 -0700 Subject: [PATCH 082/114] Added time argument to fix nep calculation --- main/FatesHistoryInterfaceMod.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c6e426cecd..51db184e95 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1559,7 +1559,7 @@ end subroutine init_dim_kinds_maps ! ======================================================================= - subroutine update_history_cbal(this,nc,nsites,sites,bc_in) + subroutine update_history_cbal(this,nc,nsites,sites,bc_in,dtime) use EDtypesMod , only : ed_site_type @@ -1570,10 +1570,12 @@ subroutine update_history_cbal(this,nc,nsites,sites,bc_in) integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) - + real(r8) , intent(in) :: dtime ! Time-step (s) + ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array + real(r8) :: inv_dtime ! inverse of dtime (faster math) type(ed_cohort_type), pointer :: ccohort ! current cohort type(ed_patch_type) , pointer :: cpatch ! current patch @@ -1585,7 +1587,9 @@ subroutine update_history_cbal(this,nc,nsites,sites,bc_in) ! --------------------------------------------------------------------------------- call this%flush_hvars(nc,upfreq_in=3) - + + inv_dtime = 1._r8/dtime + do s = 1,nsites io_si = this%iovar_map(nc)%site_index(s) @@ -1600,7 +1604,8 @@ subroutine update_history_cbal(this,nc,nsites,sites,bc_in) ! Add up the total Net Ecosystem Production ! for this timestep. [gC/m2/s] hio_nep_si(io_si) = hio_nep_si(io_si) + & - (ccohort%gpp_tstep - ccohort%resp_tstep) * g_per_kg * ccohort%n * area_inv + (ccohort%gpp_tstep - ccohort%resp_tstep) * & + g_per_kg * ccohort%n * area_inv * inv_dtime ccohort => ccohort%taller end do cpatch => cpatch%younger From 50c189c21b0e0e70519aeb0e01e66fa253738ac2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 23 Apr 2020 11:32:07 -0600 Subject: [PATCH 083/114] changing/adding some fire history output --- main/FatesHistoryInterfaceMod.F90 | 47 ++++++++++++++++++++++++++----- 1 file changed, 40 insertions(+), 7 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 51db184e95..3a1e1e2307 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -141,7 +141,6 @@ module FatesHistoryInterfaceMod integer :: ih_trimming_pa integer :: ih_area_plant_pa integer :: ih_area_treespread_pa - integer :: ih_nesterov_fire_danger_pa integer :: ih_spitfire_ROS_pa integer :: ih_effect_wspeed_pa integer :: ih_TFC_ROS_pa @@ -268,6 +267,7 @@ module FatesHistoryInterfaceMod integer :: ih_dleafon_si integer :: ih_meanliqvol_si + integer :: ih_nesterov_fire_danger_si integer :: ih_nplant_si_scpf integer :: ih_gpp_si_scpf @@ -327,7 +327,6 @@ module FatesHistoryInterfaceMod integer :: ih_c13disc_si_scpf - ! indices to (site x scls [size class bins]) variables integer :: ih_ba_si_scls integer :: ih_nplant_si_scls @@ -433,6 +432,10 @@ module FatesHistoryInterfaceMod integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age integer :: ih_secondaryforest_area_si_age + integer :: if_area_burnt_si_age + ! integer :: if_fire_rate_of_spread_front_si_age + ! integer :: if_fire_intensity_si_age + integer :: if_fire_sum_fuel_si_age ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height @@ -1733,7 +1736,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_crownarea_si_pft => this%hvars(ih_crownarea_si_pft)%r82d, & - hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & + hio_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_si)%r81d, & hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & hio_effect_wspeed_pa => this%hvars(ih_effect_wspeed_pa)%r81d, & @@ -1909,6 +1912,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_woodproduct_si => this%hvars(ih_woodproduct_si)%r81d, & hio_agesince_anthrodist_si_age => this%hvars(ih_agesince_anthrodist_si_age)%r82d, & hio_secondaryforest_area_si_age => this%hvars(ih_secondaryforest_area_si_age)%r82d, & + hio_area_burnt_si_age => this%hvars(ih_area_burnt_si_age)%r82d, & + ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & + ! hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & + hio_fire_sum_fuel_si_age => this%hvars(ih_fire_sum_fuel_si_age)%r82d, & hio_canopy_height_dist_si_height => this%hvars(ih_canopy_height_dist_si_height)%r82d, & hio_leaf_height_dist_si_height => this%hvars(ih_leaf_height_dist_si_height)%r82d, & hio_litter_moisture_si_fuel => this%hvars(ih_litter_moisture_si_fuel)%r82d, & @@ -2007,6 +2014,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & * AREA_INV * g_per_kg + ! site-level fire variables + hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI ! If hydraulics are turned on, track the error terms ! associated with dynamics @@ -2061,14 +2070,26 @@ subroutine update_history_dyn(this,nc,nsites,sites) + cpatch%area * AREA_INV endif + !!! patch-age-resolved fire variables do i_pft = 1,numpft ! for scorch height, weight the value by patch area within any given age calss (in the event that there is ! more than one patch per age class. iagepft = cpatch%age_class + (i_pft-1) * nlevage hio_scorch_height_si_agepft(io_si,iagepft) = hio_scorch_height_si_agepft(io_si,iagepft) + & cpatch%Scorch_ht(i_pft) * cpatch%area - end do + + hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & + cpatch*frac_burnt * cpatch%area * AREA_INV + + ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & + ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV + + ! hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & + ! cpatch%FI * cpatch*frac_burnt * cpatch%area * AREA_INV + + hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) = hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) + & + cpatch%sum_fuel * cpatch%area * AREA_INV ccohort => cpatch%shortest do while(associated(ccohort)) @@ -2604,7 +2625,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! Update Fire Variables - hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS @@ -4001,8 +4021,8 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & long='nesterov_fire_danger index', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_pa) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_si) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & @@ -4060,6 +4080,19 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_moisture_si_fuel ) + call this%set_history_var(vname='AREA_BURNT_BY_PATCH_AGE', units='m2/m2', & + long='spitfire area burnt by patch age (divide by patch_area_by_age to get burnt fraction by age)', & + use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_burnt_si_age ) + + call this%set_history_var(vname='SUM_FUEL_BY_PATCH_AGE', units='gC / m2 of site area', & + long='spitfire ground fuel related to ros (omits 1000hr fuels) within each patch age bin (divide by patch_area_by_age to get fuel per unit area of that-age patch)', & + use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_si_age ) + + ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & From 41d08dab8251075be218f14541073d748f5d8f22 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 23 Apr 2020 14:47:05 -0600 Subject: [PATCH 084/114] bugfixes --- main/FatesHistoryInterfaceMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3a1e1e2307..0d7acf91c4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -432,10 +432,10 @@ module FatesHistoryInterfaceMod integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age integer :: ih_secondaryforest_area_si_age - integer :: if_area_burnt_si_age - ! integer :: if_fire_rate_of_spread_front_si_age - ! integer :: if_fire_intensity_si_age - integer :: if_fire_sum_fuel_si_age + integer :: ih_area_burnt_si_age + ! integer :: ih_fire_rate_of_spread_front_si_age + ! integer :: ih_fire_intensity_si_age + integer :: ih_fire_sum_fuel_si_age ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height @@ -2080,13 +2080,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & - cpatch*frac_burnt * cpatch%area * AREA_INV + cpatch%frac_burnt * cpatch%area * AREA_INV ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV ! hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & - ! cpatch%FI * cpatch*frac_burnt * cpatch%area * AREA_INV + ! cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) = hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) + & cpatch%sum_fuel * cpatch%area * AREA_INV @@ -4090,7 +4090,7 @@ subroutine define_history_vars(this, initialize_variables) long='spitfire ground fuel related to ros (omits 1000hr fuels) within each patch age bin (divide by patch_area_by_age to get fuel per unit area of that-age patch)', & use_default='active', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_si_age ) + ivar=ivar, initialize=initialize_variables, index = ih_fire_sum_fuel_si_age ) ! Litter Variables From f3822a5da40b6d48ae92748c829ae1105050aaea Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 23 Apr 2020 17:53:06 -0600 Subject: [PATCH 085/114] added new fire intensity output vars --- main/FatesHistoryInterfaceMod.F90 | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0d7acf91c4..2a0f4ef153 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -268,6 +268,7 @@ module FatesHistoryInterfaceMod integer :: ih_meanliqvol_si integer :: ih_nesterov_fire_danger_si + integer :: ih_fire_intensity_area_product_si integer :: ih_nplant_si_scpf integer :: ih_gpp_si_scpf @@ -434,7 +435,7 @@ module FatesHistoryInterfaceMod integer :: ih_secondaryforest_area_si_age integer :: ih_area_burnt_si_age ! integer :: ih_fire_rate_of_spread_front_si_age - ! integer :: ih_fire_intensity_si_age + integer :: ih_fire_intensity_si_age integer :: ih_fire_sum_fuel_si_age ! indices to (site x height) variables @@ -1741,6 +1742,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & hio_effect_wspeed_pa => this%hvars(ih_effect_wspeed_pa)%r81d, & hio_fire_intensity_pa => this%hvars(ih_fire_intensity_pa)%r81d, & + hio_fire_intensity_area_product_si => this%hvars(ih_fire_intensity_area_product_si)%r81d, & hio_fire_area_pa => this%hvars(ih_fire_area_pa)%r81d, & hio_fire_fuel_bulkd_pa => this%hvars(ih_fire_fuel_bulkd_pa)%r81d, & hio_fire_fuel_eff_moist_pa => this%hvars(ih_fire_fuel_eff_moist_pa)%r81d, & @@ -1914,7 +1916,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_secondaryforest_area_si_age => this%hvars(ih_secondaryforest_area_si_age)%r82d, & hio_area_burnt_si_age => this%hvars(ih_area_burnt_si_age)%r82d, & ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & - ! hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & + hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & hio_fire_sum_fuel_si_age => this%hvars(ih_fire_sum_fuel_si_age)%r82d, & hio_canopy_height_dist_si_height => this%hvars(ih_canopy_height_dist_si_height)%r82d, & hio_leaf_height_dist_si_height => this%hvars(ih_leaf_height_dist_si_height)%r82d, & @@ -2085,8 +2087,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV - ! hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & - ! cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV + hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) = hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) + & cpatch%sum_fuel * cpatch%area * AREA_INV @@ -2641,6 +2643,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch%litter_moisture(i_fuel) * cpatch%area * AREA_INV end do + + hio_fire_intensity_area_product_si(io_si) = hio_fire_intensity_area_product_si(io_si) + & + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV + ! Update Litter Flux Variables litt_c => cpatch%litter(element_pos(carbon12_element)) @@ -4044,6 +4050,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_pa ) + call this%set_history_var(vname='FIRE_INTENSITY_AREA_PRODUCT', units='kJ/m/s', & + long='spitfire product of fire intensity and burned area (divide by FIRE_AREA to get area-weifghted mean intensity)', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_area_product_si ) + call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area burn fraction', use_default='active', & avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & @@ -4086,6 +4098,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_burnt_si_age ) + call this%set_history_var(vname='FIRE_INTENSITY_BY_PATCH_AGE', units='kJ/m/2', & + long='product of fire intensity and burned area, resolved by patch age (so divide by AREA_BURNT_BY_PATCH_AGE to get burned-area-weighted-average intensity', & + use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_si_age ) + call this%set_history_var(vname='SUM_FUEL_BY_PATCH_AGE', units='gC / m2 of site area', & long='spitfire ground fuel related to ros (omits 1000hr fuels) within each patch age bin (divide by patch_area_by_age to get fuel per unit area of that-age patch)', & use_default='active', & From a5fe759eb6d6c3c4e8e03049ed027f351eef7ba5 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 24 Apr 2020 11:39:00 -0600 Subject: [PATCH 086/114] changed _pa vars to be _si --- main/FatesHistoryInterfaceMod.F90 | 106 +++++++++++++++--------------- 1 file changed, 53 insertions(+), 53 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 2a0f4ef153..fed76016db 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -141,16 +141,6 @@ module FatesHistoryInterfaceMod integer :: ih_trimming_pa integer :: ih_area_plant_pa integer :: ih_area_treespread_pa - integer :: ih_spitfire_ROS_pa - integer :: ih_effect_wspeed_pa - integer :: ih_TFC_ROS_pa - integer :: ih_fire_intensity_pa - integer :: ih_fire_area_pa - integer :: ih_fire_fuel_bulkd_pa - integer :: ih_fire_fuel_eff_moist_pa - integer :: ih_fire_fuel_sav_pa - integer :: ih_fire_fuel_mef_pa - integer :: ih_sum_fuel_pa integer :: ih_cwd_elcwd @@ -269,6 +259,16 @@ module FatesHistoryInterfaceMod integer :: ih_nesterov_fire_danger_si integer :: ih_fire_intensity_area_product_si + integer :: ih_spitfire_ROS_si + integer :: ih_effect_wspeed_si + integer :: ih_TFC_ROS_si + integer :: ih_fire_intensity_si + integer :: ih_fire_area_si + integer :: ih_fire_fuel_bulkd_si + integer :: ih_fire_fuel_eff_moist_si + integer :: ih_fire_fuel_sav_si + integer :: ih_fire_fuel_mef_si + integer :: ih_sum_fuel_si integer :: ih_nplant_si_scpf integer :: ih_gpp_si_scpf @@ -1738,17 +1738,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_crownarea_si_pft => this%hvars(ih_crownarea_si_pft)%r82d, & hio_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_si)%r81d, & - hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & - hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & - hio_effect_wspeed_pa => this%hvars(ih_effect_wspeed_pa)%r81d, & - hio_fire_intensity_pa => this%hvars(ih_fire_intensity_pa)%r81d, & + hio_spitfire_ros_si => this%hvars(ih_spitfire_ROS_si)%r81d, & + hio_tfc_ros_si => this%hvars(ih_TFC_ROS_si)%r81d, & + hio_effect_wspeed_si => this%hvars(ih_effect_wspeed_si)%r81d, & + hio_fire_intensity_si => this%hvars(ih_fire_intensity_si)%r81d, & hio_fire_intensity_area_product_si => this%hvars(ih_fire_intensity_area_product_si)%r81d, & - hio_fire_area_pa => this%hvars(ih_fire_area_pa)%r81d, & - hio_fire_fuel_bulkd_pa => this%hvars(ih_fire_fuel_bulkd_pa)%r81d, & - hio_fire_fuel_eff_moist_pa => this%hvars(ih_fire_fuel_eff_moist_pa)%r81d, & - hio_fire_fuel_sav_pa => this%hvars(ih_fire_fuel_sav_pa)%r81d, & - hio_fire_fuel_mef_pa => this%hvars(ih_fire_fuel_mef_pa)%r81d, & - hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d, & + hio_fire_area_si => this%hvars(ih_fire_area_si)%r81d, & + hio_fire_fuel_bulkd_si => this%hvars(ih_fire_fuel_bulkd_si)%r81d, & + hio_fire_fuel_eff_moist_si => this%hvars(ih_fire_fuel_eff_moist_si)%r81d, & + hio_fire_fuel_sav_si => this%hvars(ih_fire_fuel_sav_si)%r81d, & + hio_fire_fuel_mef_si => this%hvars(ih_fire_fuel_mef_si)%r81d, & + hio_sum_fuel_si => this%hvars(ih_sum_fuel_si)%r81d, & hio_litter_in_si => this%hvars(ih_litter_in_si)%r81d, & hio_litter_out_si => this%hvars(ih_litter_out_si)%r81d, & hio_seed_bank_si => this%hvars(ih_seed_bank_si)%r81d, & @@ -2627,16 +2627,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! Update Fire Variables - hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front - hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed - hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS - hio_fire_intensity_pa(io_pa) = cpatch%FI - hio_fire_area_pa(io_pa) = cpatch%frac_burnt - hio_fire_fuel_bulkd_pa(io_pa) = cpatch%fuel_bulkd - hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist - hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav - hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef - hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * g_per_kg * patch_scaling_scalar + hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV + hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV + hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV + hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV + hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV + hio_fire_fuel_bulkd_si(io_si) = hio_fire_fuel_bulkd_si(io_si) + cpatch%fuel_bulkd * cpatch%area * AREA_INV + hio_fire_fuel_eff_moist_si(io_si) = hio_fire_fuel_eff_moist_si(io_si) + cpatch%fuel_eff_moist * cpatch%area * AREA_INV + hio_fire_fuel_sav_si(io_si) = hio_fire_fuel_sav_si(io_si) + cpatch%fuel_sav * cpatch%area * AREA_INV + hio_fire_fuel_mef_si(io_si) = hio_fire_fuel_mef_si(io_si) + cpatch%fuel_mef * cpatch%area * AREA_INV + hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * g_per_kg * patch_scaling_scalar * cpatch%area * AREA_INV do i_fuel = 1,nfsc hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & @@ -3825,17 +3825,17 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) call this%set_history_var(vname='SITE_COLD_STATUS', units='0,1,2', & @@ -4032,23 +4032,23 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_pa) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_si) call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_si ) call this%set_history_var(vname='FIRE_TFC_ROS', units='kgC/m2', & long ='total fuel consumed', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_si ) call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_si ) call this%set_history_var(vname='FIRE_INTENSITY_AREA_PRODUCT', units='kJ/m/s', & long='spitfire product of fire intensity and burned area (divide by FIRE_AREA to get area-weifghted mean intensity)', & @@ -4058,34 +4058,34 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FIRE_AREA', units='fraction', & long='spitfire fire area burn fraction', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_area_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_area_si ) call this%set_history_var(vname='fire_fuel_mef', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_si ) call this%set_history_var(vname='fire_fuel_bulkd', units='kg biomass/m3', & long='spitfire fuel bulk density', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_si ) call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si ) call this%set_history_var(vname='fire_fuel_sav', units='per m', & long='spitfire fuel surface/volume ', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_si ) call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & long='total ground fuel related to ros (omits 1000hr fuels)', & use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_si ) call this%set_history_var(vname='FUEL_MOISTURE_NFSC', units='-', & long='spitfire size-resolved fuel moisture', use_default='active', & From d66dac84dcb3e68001b25b9e6b06922a6f9c5ac8 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 24 Apr 2020 13:48:24 -0600 Subject: [PATCH 087/114] bugixes --- main/FatesHistoryInterfaceMod.F90 | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index fed76016db..7920653c35 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1685,7 +1685,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column - real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling real(r8) :: dbh ! diameter ("at breast height") real(r8) :: coage ! cohort age real(r8) :: npp_partition_error ! a check that the NPP partitions sum to carbon allocation @@ -1738,7 +1737,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_crownarea_si_pft => this%hvars(ih_crownarea_si_pft)%r82d, & hio_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_si)%r81d, & - hio_spitfire_ros_si => this%hvars(ih_spitfire_ROS_si)%r81d, & + hio_spitfire_ROS_si => this%hvars(ih_spitfire_ROS_si)%r81d, & hio_tfc_ros_si => this%hvars(ih_TFC_ROS_si)%r81d, & hio_effect_wspeed_si => this%hvars(ih_effect_wspeed_si)%r81d, & hio_fire_intensity_si => this%hvars(ih_fire_intensity_si)%r81d, & @@ -2619,13 +2618,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Patch specific variables that are already calculated ! These things are all duplicated. Should they all be converted to LL or array structures RF? ! define scalar to counteract the patch albedo scaling logic for conserved quantities - - if (cpatch%area .gt. 0._r8 .and. cpatch%total_canopy_area .gt.0 ) then - patch_scaling_scalar = min(1._r8, cpatch%area / cpatch%total_canopy_area) - else - patch_scaling_scalar = 0._r8 - endif - + ! Update Fire Variables hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV @@ -2636,7 +2629,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_fuel_eff_moist_si(io_si) = hio_fire_fuel_eff_moist_si(io_si) + cpatch%fuel_eff_moist * cpatch%area * AREA_INV hio_fire_fuel_sav_si(io_si) = hio_fire_fuel_sav_si(io_si) + cpatch%fuel_sav * cpatch%area * AREA_INV hio_fire_fuel_mef_si(io_si) = hio_fire_fuel_mef_si(io_si) + cpatch%fuel_mef * cpatch%area * AREA_INV - hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * g_per_kg * patch_scaling_scalar * cpatch%area * AREA_INV + hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * g_per_kg * cpatch%area * AREA_INV do i_fuel = 1,nfsc hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & @@ -3825,17 +3818,17 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) call this%set_history_var(vname='SITE_COLD_STATUS', units='0,1,2', & From 95d8ef61b6b6800f91aa0fa7274f464a79c10060 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Apr 2020 12:49:46 -0700 Subject: [PATCH 088/114] Removing usage of bc_in%t_veg24_si --- biogeochem/EDMortalityFunctionsMod.F90 | 5 +++-- biogeochem/EDPhysiologyMod.F90 | 11 +++++++---- main/FatesInterfaceMod.F90 | 11 +++++------ 3 files changed, 15 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index af6334e71e..30be3fa835 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -62,7 +62,7 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor real(r8),intent(out) :: smort ! size dependent senescence term real(r8),intent(out) :: asmort ! age dependent senescence term - + integer :: ifp real(r8) :: frac ! relativised stored carbohydrate real(r8) :: leaf_c_target ! target leaf biomass kgC real(r8) :: store_c @@ -173,7 +173,8 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor ! Eastern US carbon sink. Glob. Change Biol., 12, 2370-2390, ! doi: 10.1111/j.1365-2486.2006.01254.x - temp_in_C = bc_in%t_veg24_si - tfrz + ifp = cohort_in%patchptr%patchno + temp_in_C = bc_in%t_veg24_pa(ifp) - tfrz temp_dep_fraction = max(0.0_r8, min(1.0_r8, 1.0_r8 - (temp_in_C - & EDPftvarcon_inst%freezetol(cohort_in%pft))/frost_mort_buffer) ) frmort = EDPftvarcon_inst%mort_scalar_coldstress(cohort_in%pft) * temp_dep_fraction diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3e11d37aa9..7240bad544 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -581,6 +581,7 @@ subroutine phenology( currentSite, bc_in ) real(r8) :: gdd_threshold ! GDD accumulation function, integer :: ilayer_swater ! Layer index for soil water ! which also depends on chilling days. + integer :: n_patch ! number of patches on this site integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. real(r8) :: temp_in_C ! daily averaged temperature in celcius @@ -612,7 +613,9 @@ subroutine phenology( currentSite, bc_in ) !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 !Parameters, default from from SDGVM model of senesence - temp_in_C = bc_in%t_veg24_si - tfrz + + n_patch = currentSite%youngest_patch%patchno + temp_in_C = sum(bc_in%t_veg24_pa(1:n_patch),dim=1)/real(n_patch,r8) - tfrz !-----------------Cold Phenology--------------------! @@ -663,8 +666,8 @@ subroutine phenology( currentSite, bc_in ) ! ! accumulate the GDD using daily mean temperatures ! Don't accumulate GDD during the growing season (that wouldn't make sense) - if (bc_in%t_veg24_si .gt. tfrz.and. currentSite%cstatus == phen_cstat_iscold) then - currentSite%grow_deg_days = currentSite%grow_deg_days + bc_in%t_veg24_si - tfrz + if (temp_in_C .gt. 0._r8 .and. currentSite%cstatus == phen_cstat_iscold) then + currentSite%grow_deg_days = currentSite%grow_deg_days + temp_in_C endif !this logic is to prevent GDD accumulating after the leaves have fallen and before the @@ -2109,7 +2112,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) if ( .not. use_century_tfunc ) then !calculate rate constant scalar for soil temperature,assuming that the base rate constants - !are assigned for non-moisture limiting conditions at 25C. + !are assigned for non-moisture limiting conditions at 25C. if (bc_in%t_veg24_pa(ifp) >= tfrz) then t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d72f2b5cd6..ca88ef3afd 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -25,6 +25,7 @@ module FatesInterfaceMod use EDTypesMod , only : element_list use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse + use FatesConstantsMod , only : fates_unset_r8 use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -315,13 +316,11 @@ module FatesInterfaceMod ! Vegetation Dynamics ! --------------------------------------------------------------------------------- - ! The site level 24 hour vegetation temperature is used for various purposes during vegetation - ! dynamics. However, we are currently using the bare ground patch's value [K] - ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. - ! It is possible that the bare-ground value is where the average is being stored. - ! (RGK-01-2017) + ! THIS VARIABLE IS NOW DEPRECATED AND SHOULD NOT BE USED + ! THIS WILL BE REMOVED FROM THE API ALONG WITH THE NEXT MAJOR API CHANGE real(r8) :: t_veg24_si + ! Patch 24 hour vegetation temperature [K] real(r8),allocatable :: t_veg24_pa(:) @@ -890,7 +889,7 @@ subroutine zero_bcs(this,s) ! Input boundaries - this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%t_veg24_si = fates_unset_r8 this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 this%bc_in(s)%precip24_pa(:) = 0.0_r8 this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 From 6345c8f966b1e6f4cc4e44cfe6862524623f6035 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Apr 2020 13:10:31 -0700 Subject: [PATCH 089/114] Added area weighting to 24hr veg temperature. --- biogeochem/EDPhysiologyMod.F90 | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7240bad544..1f2b974776 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -32,7 +32,7 @@ module EDPhysiologyMod use EDTypesMod , only : site_massbal_type use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : numWaterMem - use EDTypesMod , only : dl_sf, dinc_ed + use EDTypesMod , only : dl_sf, dinc_ed, area_inv use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : ilabile @@ -564,6 +564,7 @@ subroutine phenology( currentSite, bc_in ) ! ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch integer :: model_day_int ! integer model day 1 - inf integer :: ncolddays ! no days underneath the threshold for leaf drop integer :: i_wmem ! Loop counter for water mem days @@ -581,7 +582,6 @@ subroutine phenology( currentSite, bc_in ) real(r8) :: gdd_threshold ! GDD accumulation function, integer :: ilayer_swater ! Layer index for soil water ! which also depends on chilling days. - integer :: n_patch ! number of patches on this site integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. real(r8) :: temp_in_C ! daily averaged temperature in celcius @@ -613,10 +613,15 @@ subroutine phenology( currentSite, bc_in ) !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 !Parameters, default from from SDGVM model of senesence - - n_patch = currentSite%youngest_patch%patchno - temp_in_C = sum(bc_in%t_veg24_pa(1:n_patch),dim=1)/real(n_patch,r8) - tfrz - + temp_in_C = 0._r8 + cpatch => CurrentSite%oldest_patch + do while(associated(cpatch)) + temp_in_C = temp_in_C + bc_in%t_veg24_pa(cpatch%patchno)*cpatch%area + cpatch => cpatch%younger + end do + temp_in_C = temp_in_C * area_inv - tfrz + + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters From 987f521aabae51166d50192b9845d952c70cffc0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Apr 2020 13:56:52 -0700 Subject: [PATCH 090/114] updated long-names on chiltemp and coldtemp parameters --- parameter_files/fates_params_default.cdl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index cf374a7a01..c3868851cc 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -650,10 +650,10 @@ variables: fates_phen_c:long_name = "GDD accumulation function, exponent parameter: gdd_thesh = a + b exp(c*ncd)" ; double fates_phen_chiltemp ; fates_phen_chiltemp:units = "degrees C" ; - fates_phen_chiltemp:long_name = "chilling day counting threshold" ; + fates_phen_chiltemp:long_name = "chilling day counting threshold for vegetation" ; double fates_phen_coldtemp ; fates_phen_coldtemp:units = "degrees C" ; - fates_phen_coldtemp:long_name = "temperature exceedance to flag a cold-day for temperature leaf drop" ; + fates_phen_coldtemp:long_name = "vegetation temperature exceedance that flags a cold-day for leaf-drop" ; double fates_phen_doff_time ; fates_phen_doff_time:units = "days" ; fates_phen_doff_time:long_name = "day threshold compared against days since leaves became off-allometry" ; From 538415c682c6b0ada7eb0f9471043ec8561371df Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 27 Apr 2020 17:15:48 -0600 Subject: [PATCH 091/114] added new fire variable * fire_area metrics --- main/FatesHistoryInterfaceMod.F90 | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7920653c35..49fc51fe85 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -259,9 +259,11 @@ module FatesHistoryInterfaceMod integer :: ih_nesterov_fire_danger_si integer :: ih_fire_intensity_area_product_si - integer :: ih_spitfire_ROS_si + integer :: ih_spitfire_ros_si + integer :: ih_fire_ros_area_product_si integer :: ih_effect_wspeed_si - integer :: ih_TFC_ROS_si + integer :: ih_tfc_ros_si + integer :: ih_tfc_ros_area_product_si integer :: ih_fire_intensity_si integer :: ih_fire_area_si integer :: ih_fire_fuel_bulkd_si @@ -1737,8 +1739,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_crownarea_si_pft => this%hvars(ih_crownarea_si_pft)%r82d, & hio_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_si)%r81d, & - hio_spitfire_ROS_si => this%hvars(ih_spitfire_ROS_si)%r81d, & - hio_tfc_ros_si => this%hvars(ih_TFC_ROS_si)%r81d, & + hio_spitfire_ros_si => this%hvars(ih_spitfire_ros_si)%r81d, & + hio_fire_ros_area_product_si=> this%hvars(ih_fire_ros_area_product_si)%r81d, & + hio_tfc_ros_si => this%hvars(ih_tfc_ros_si)%r81d, & + hio_tfc_ros_area_product_si => this%hvars(ih_tfc_ros_area_product_si)%r81d, & hio_effect_wspeed_si => this%hvars(ih_effect_wspeed_si)%r81d, & hio_fire_intensity_si => this%hvars(ih_fire_intensity_si)%r81d, & hio_fire_intensity_area_product_si => this%hvars(ih_fire_intensity_area_product_si)%r81d, & @@ -2621,8 +2625,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Update Fire Variables hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV + hio_fire_ros_area_product_si(io_si)= hio_fire_ros_area_product_si(io_si) + & + cpatch%frac_burnt * cpatch%ROS_front * cpatch%area * AREA_INV hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV + hio_tfc_ros_area_product_si(io_si) = hio_tfc_ros_area_product_si(io_si) + & + cpatch%frac_burnt * cpatch%TFC_ROS * cpatch%area * AREA_INV hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV hio_fire_fuel_bulkd_si(io_si) = hio_fire_fuel_bulkd_si(io_si) + cpatch%fuel_bulkd * cpatch%area * AREA_INV @@ -4026,7 +4034,12 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FIRE_ROS', units='m/min', & long='fire rate of spread m/min', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_si) + ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ros_si) + + call this%set_history_var(vname='FIRE_ROS_AREA_PRODUCT', units='m/min', & + long='product of fire rate of spread (m/min) and burned area (fraction)--divide by FIRE_AREA to get burned-area-weighted-mean ROS', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_ros_area_product_si) call this%set_history_var(vname='EFFECT_WSPEED', units='none', & long ='effective windspeed for fire spread', use_default='active', & @@ -4036,7 +4049,12 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FIRE_TFC_ROS', units='kgC/m2', & long ='total fuel consumed', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_si ) + ivar=ivar, initialize=initialize_variables, index = ih_tfc_ros_si ) + + call this%set_history_var(vname='FIRE_TFC_ROS_AREA_PRODUCT', units='kgC/m2', & + long ='product of total fuel consumed and burned area--divide by FIRE_AREA to get burned-area-weighted-mean TFC', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_tfc_ros_area_product_si ) call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & long='spitfire fire intensity: kJ/m/s', use_default='active', & From 6f2803dd70dc9be8c6066fc89ffb869c476d523b Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 28 Apr 2020 11:38:21 -0600 Subject: [PATCH 092/114] added element-indexed burn flux var and fuel-indexed frac-burned var --- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 49fc51fe85..d854aaffb9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -161,6 +161,7 @@ module FatesHistoryInterfaceMod integer :: ih_fines_bg_elem integer :: ih_cwd_ag_elem integer :: ih_cwd_bg_elem + integer :: ih_burn_flux_elem integer :: ih_daily_temp integer :: ih_daily_rh @@ -490,6 +491,7 @@ module FatesHistoryInterfaceMod ! indices to (site x fuel class) variables integer :: ih_litter_moisture_si_fuel + integer :: ih_burnt_frac_litter_si_fuel ! indices to (site x cwd size class) variables integer :: ih_cwd_ag_si_cwdsc @@ -1830,6 +1832,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cambialfiremort_si_scpf => this%hvars(ih_cambialfiremort_si_scpf)%r82d, & hio_fire_c_to_atm_si => this%hvars(ih_fire_c_to_atm_si)%r81d, & + hio_burn_flux_elem => this%hvars(ih_burn_flux_elem)%r82d, & hio_m1_si_scls => this%hvars(ih_m1_si_scls)%r82d, & hio_m2_si_scls => this%hvars(ih_m2_si_scls)%r82d, & @@ -1921,6 +1924,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & hio_fire_sum_fuel_si_age => this%hvars(ih_fire_sum_fuel_si_age)%r82d, & + hio_burnt_frac_litter_si_fuel => this%hvars(ih_burnt_frac_litter_si_fuel)%r82d, & hio_canopy_height_dist_si_height => this%hvars(ih_canopy_height_dist_si_height)%r82d, & hio_leaf_height_dist_si_height => this%hvars(ih_leaf_height_dist_si_height)%r82d, & hio_litter_moisture_si_fuel => this%hvars(ih_litter_moisture_si_fuel)%r82d, & @@ -1991,6 +1995,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) do el = 1, num_elements site_mass => sites(s)%mass_balance(el) hio_err_fates_si(io_si,el) = site_mass%err_fates * mg_per_kg + + ! Total element lost to atmosphere from burning (kg/site/day -> g/m2/s) + hio_burn_flux_elem(io_si,el) = & + sites(s)%mass_balance(el)%burn_flux_to_atm * & + g_per_kg * ha_per_m2 * days_per_sec + end do hio_canopy_spread_si(io_si) = sites(s)%spread @@ -2642,6 +2652,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_fuel = 1,nfsc hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & cpatch%litter_moisture(i_fuel) * cpatch%area * AREA_INV + + hio_burnt_frac_litter_si_fuel(io_si, i_fuel) = hio_burnt_frac_litter_si_fuel(io_si, i_fuel) + & + cpatch%burnt_frac_litter(i_fuel) * cpatch%frac_burnt * cpatch%area * AREA_INV end do @@ -4121,6 +4134,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_sum_fuel_si_age ) + call this%set_history_var(vname='BURNT_LITTER_FRAC_AREA_PRODUCT', units='fraction', & + long='product of fraction of fuel burnt and burned area (divide by FIRE_AREA to get burned-area-weighted mean fraction fuel burnt)', & + use_default='active', & + avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_burnt_frac_litter_si_fuel ) + ! Litter Variables @@ -5280,6 +5299,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) + call this%set_history_var(vname='FIRE_FLUX', units='g/m^2/s', & + long='ED/SPitfire loss to atmosphere of elements', use_default='active', & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_burn_flux_elem ) + call this%set_history_var(vname='CBALANCE_ERROR_FATES', units='mgC/day', & long='total carbon error, FATES', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & From 82cb0e45395b38b6dc697133e01dbcd097118056 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 28 Apr 2020 13:28:07 -0600 Subject: [PATCH 093/114] deleted rather than commented-out prior call to ZeroMassBalFlux --- main/EDMainMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 31f9d930e8..b5fcb7d31f 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -721,7 +721,6 @@ subroutine TotalBalanceCheck (currentSite, call_index ) if(call_index == final_check_id) then site_mass%old_stock = total_stock site_mass%err_fates = net_flux - change_in_stock - call site_mass%ZeroMassBalFlux() end if end do From cc7711514054e19f8267cc30a7062800be11b8af Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 29 Apr 2020 12:48:26 -0600 Subject: [PATCH 094/114] getting rid of all the _pa variables --- main/FatesHistoryInterfaceMod.F90 | 300 +++++++++++++----------------- 1 file changed, 127 insertions(+), 173 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 51db184e95..1fcad70616 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -138,9 +138,9 @@ module FatesHistoryInterfaceMod ! Indices to 1D Patch variables - integer :: ih_trimming_pa - integer :: ih_area_plant_pa - integer :: ih_area_treespread_pa + integer :: ih_trimming_si + integer :: ih_area_plant_si + integer :: ih_area_trees_si integer :: ih_nesterov_fire_danger_pa integer :: ih_spitfire_ROS_pa integer :: ih_effect_wspeed_pa @@ -177,25 +177,25 @@ module FatesHistoryInterfaceMod integer :: ih_daily_rh integer :: ih_daily_prec - integer :: ih_bstore_pa - integer :: ih_bdead_pa - integer :: ih_balive_pa - integer :: ih_bleaf_pa - integer :: ih_bsapwood_pa - integer :: ih_bfineroot_pa - integer :: ih_btotal_pa - integer :: ih_agb_pa - integer :: ih_npp_pa - integer :: ih_gpp_pa - integer :: ih_aresp_pa - integer :: ih_maint_resp_pa - integer :: ih_growth_resp_pa - integer :: ih_ar_canopy_pa - integer :: ih_gpp_canopy_pa - integer :: ih_ar_understory_pa - integer :: ih_gpp_understory_pa - integer :: ih_canopy_biomass_pa - integer :: ih_understory_biomass_pa + integer :: ih_bstore_si + integer :: ih_bdead_si + integer :: ih_balive_si + integer :: ih_bleaf_si + integer :: ih_bsapwood_si + integer :: ih_bfineroot_si + integer :: ih_btotal_si + integer :: ih_agb_si + integer :: ih_npp_si + integer :: ih_gpp_si + integer :: ih_aresp_si + integer :: ih_maint_resp_si + integer :: ih_growth_resp_si + integer :: ih_ar_canopy_si + integer :: ih_gpp_canopy_si + integer :: ih_ar_understory_si + integer :: ih_gpp_understory_si + integer :: ih_canopy_biomass_si + integer :: ih_understory_biomass_si ! Indices to site by size-class by age variables integer :: ih_nplant_si_scag @@ -217,7 +217,6 @@ module FatesHistoryInterfaceMod ! Indices to (site) variables integer :: ih_nep_si - integer :: ih_npp_si integer :: ih_c_stomata_si integer :: ih_c_lblayer_si @@ -1679,7 +1678,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! time-since-anthropogenic-disturbance of secondary forest - real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling real(r8) :: dbh ! diameter ("at breast height") @@ -1722,9 +1720,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & - hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & - hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & - hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & + hio_trimming_si => this%hvars(ih_trimming_si)%r81d, & + hio_area_plant_si => this%hvars(ih_area_plant_si)%r81d, & + hio_area_trees_si => this%hvars(ih_area_trees_si)%r81d, & hio_canopy_spread_si => this%hvars(ih_canopy_spread_si)%r81d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & @@ -1756,16 +1754,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_seed_decay_elem => this%hvars(ih_seed_decay_elem)%r82d, & hio_seed_germ_elem => this%hvars(ih_seed_germ_elem)%r82d, & - hio_bstore_pa => this%hvars(ih_bstore_pa)%r81d, & - hio_bdead_pa => this%hvars(ih_bdead_pa)%r81d, & - hio_balive_pa => this%hvars(ih_balive_pa)%r81d, & - hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & - hio_bsapwood_pa => this%hvars(ih_bsapwood_pa)%r81d, & - hio_bfineroot_pa => this%hvars(ih_bfineroot_pa)%r81d, & - hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d, & - hio_agb_pa => this%hvars(ih_agb_pa)%r81d, & - hio_canopy_biomass_pa => this%hvars(ih_canopy_biomass_pa)%r81d, & - hio_understory_biomass_pa => this%hvars(ih_understory_biomass_pa)%r81d, & + hio_bstore_si => this%hvars(ih_bstore_si)%r81d, & + hio_bdead_si => this%hvars(ih_bdead_si)%r81d, & + hio_balive_si => this%hvars(ih_balive_si)%r81d, & + hio_bleaf_si => this%hvars(ih_bleaf_si)%r81d, & + hio_bsapwood_si => this%hvars(ih_bsapwood_si)%r81d, & + hio_bfineroot_si => this%hvars(ih_bfineroot_si)%r81d, & + hio_btotal_si => this%hvars(ih_btotal_si)%r81d, & + hio_agb_si => this%hvars(ih_agb_si)%r81d, & + hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & + hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & hio_gpp_si_scpf => this%hvars(ih_gpp_si_scpf)%r82d, & hio_npp_totl_si_scpf => this%hvars(ih_npp_totl_si_scpf)%r82d, & hio_npp_leaf_si_scpf => this%hvars(ih_npp_leaf_si_scpf)%r82d, & @@ -1963,9 +1961,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) io_pa1 = this%iovar_map(nc)%patch1_index(s) io_soipa = io_pa1-1 - ! Set trimming on the soil patch to 1.0 - hio_trimming_pa(io_soipa) = 1.0_r8 - ! Total carbon model error [kgC/day -> mgC/day] hio_cbal_err_fates_si(io_si) = & sites(s)%mass_balance(element_pos(carbon12_element))%err_fates * mg_per_kg @@ -2070,6 +2065,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do + if(associated(cpatch%tallest))then + hio_trimming_si(io_si) = hio_trimming_si(io_si) + cpatch%tallest%canopy_trim * cpatch%area * AREA_INV + endif + + hio_area_plant_si(io_si) = hio_area_plant_si(io_si) + min(cpatch%total_canopy_area,cpatch%area) * AREA_INV + + hio_area_trees_si(io_si) = hio_area_trees_si(io_si) + min(cpatch%total_tree_area,cpatch%area) * AREA_INV + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -2082,37 +2085,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - - ! for quantities that are at the CLM patch level, because of the way - ! that CLM patches are weighted for radiative purposes this # density needs - ! to be over either ED patch canopy area or ED patch total area, whichever is less - n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) - - ! for quantities that are natively at column level, calculate plant - ! density using whole area - n_perm2 = ccohort%n * AREA_INV - - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif - - if(associated(cpatch%tallest))then - hio_trimming_pa(io_pa) = cpatch%tallest%canopy_trim - else - hio_trimming_pa(io_pa) = 0.0_r8 - endif - - hio_area_plant_pa(io_pa) = 1._r8 - - if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then - hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & - / min(cpatch%total_canopy_area,cpatch%area) - else - hio_area_treespread_pa(io_pa) = 0.0_r8 - end if - + n_perm2 = ccohort%n * AREA_INV + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + ccohort%c_area * AREA_INV @@ -2160,16 +2134,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) alive_c = leaf_c + fnrt_c + sapw_c total_c = alive_c + store_c + struct_c - hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * leaf_c * g_per_kg - hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * store_c * g_per_kg - hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * struct_c * g_per_kg - hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * alive_c * g_per_kg + hio_bleaf_si(io_si) = hio_bleaf_si(io_si) + n_perm2 * leaf_c * g_per_kg + hio_bstore_si(io_si) = hio_bstore_si(io_si) + n_perm2 * store_c * g_per_kg + hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_c * g_per_kg + hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_c * g_per_kg - hio_bsapwood_pa(io_pa) = hio_bsapwood_pa(io_pa) + n_density * sapw_c * g_per_kg - hio_bfineroot_pa(io_pa) = hio_bfineroot_pa(io_pa) + n_density * fnrt_c * g_per_kg - hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * total_c * g_per_kg + hio_bsapwood_si(io_si) = hio_bsapwood_si(io_si) + n_perm2 * sapw_c * g_per_kg + hio_bfineroot_si(io_si) = hio_bfineroot_si(io_si) + n_perm2 * fnrt_c * g_per_kg + hio_btotal_si(io_si) = hio_btotal_si(io_si) + n_perm2 * total_c * g_per_kg - hio_agb_pa(io_pa) = hio_agb_pa(io_pa) + n_density * g_per_kg * & + hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * g_per_kg * & ( leaf_c + (sapw_c + struct_c + store_c) * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) ) ! Update PFT partitioned biomass components @@ -2378,7 +2352,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & leaf_c * ccohort%n - hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * total_c * g_per_kg + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_c * g_per_kg !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2471,8 +2445,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_c * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & leaf_c * ccohort%n - hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + & - n_density * total_c * g_per_kg + hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & + n_perm2 * total_c * g_per_kg !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n @@ -3005,7 +2979,6 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index - real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_area_by_age(nlevage) ! patch area in each bin for normalizing purposes real(r8) :: canopy_area_by_age(nlevage) ! canopy area in each bin for normalizing purposes @@ -3016,12 +2989,11 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) type(ed_cohort_type),pointer :: ccohort real(r8) :: per_dt_tstep ! Time step in frequency units (/s) - associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & - hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & - hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & - hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & - hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d, & + associate( hio_gpp_si => this%hvars(ih_gpp_si)%r81d, & hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_aresp_si => this%hvars(ih_aresp_si)%r81d, & + hio_maint_resp_si => this%hvars(ih_maint_resp_si)%r81d, & + hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & @@ -3031,10 +3003,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & - hio_gpp_canopy_pa => this%hvars(ih_gpp_canopy_pa)%r81d, & - hio_ar_canopy_pa => this%hvars(ih_ar_canopy_pa)%r81d, & - hio_gpp_understory_pa => this%hvars(ih_gpp_understory_pa)%r81d, & - hio_ar_understory_pa => this%hvars(ih_ar_understory_pa)%r81d, & + hio_gpp_canopy_si => this%hvars(ih_gpp_canopy_si)%r81d, & + hio_ar_canopy_si => this%hvars(ih_ar_canopy_si)%r81d, & + hio_gpp_understory_si => this%hvars(ih_gpp_understory_si)%r81d, & + hio_ar_understory_si => this%hvars(ih_ar_understory_si)%r81d, & hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & @@ -3132,14 +3104,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ccohort => cpatch%shortest do while(associated(ccohort)) - ! TODO: we need a standardized logical function on this (used lots, RGK) - if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) - n_perm2 = ccohort%n * AREA_INV - else - n_density = 0.0_r8 - n_perm2 = 0.0_r8 - endif + n_perm2 = ccohort%n * AREA_INV if ( .not. ccohort%isnew ) then @@ -3147,21 +3112,18 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) - ! scale up cohort fluxes to their patches - hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & - ccohort%npp_tstep * g_per_kg * n_density * per_dt_tstep - hio_gpp_pa(io_pa) = hio_gpp_pa(io_pa) + & - ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep - hio_aresp_pa(io_pa) = hio_aresp_pa(io_pa) + & - ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep - hio_growth_resp_pa(io_pa) = hio_growth_resp_pa(io_pa) + & - ccohort%resp_g * g_per_kg * n_density * per_dt_tstep - hio_maint_resp_pa(io_pa) = hio_maint_resp_pa(io_pa) + & - ccohort%resp_m * g_per_kg * n_density * per_dt_tstep + ! scale up cohort fluxes to the site level + hio_npp_si(io_si) = hio_npp_si(io_si) + & + ccohort%npp_tstep * g_per_kg * n_perm2 * per_dt_tstep + hio_gpp_si(io_si) = hio_gpp_si(io_si) + & + ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + hio_aresp_si(io_si) = hio_aresp_si(io_si) + & + ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep + hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & + ccohort%resp_g * g_per_kg * n_perm2 * per_dt_tstep + hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & + ccohort%resp_m * g_per_kg * n_perm2 * per_dt_tstep - ! map ed cohort-level npp fluxes to clm column fluxes - hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * g_per_kg * per_dt_tstep - ! aggregate MR fluxes to the site level hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & * n_perm2 * sec_per_day * days_per_year @@ -3212,10 +3174,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) if (ccohort%canopy_layer .eq. 1) then ! ! bulk fluxes are in gC / m2 / s - hio_gpp_canopy_pa(io_pa) = hio_gpp_canopy_pa(io_pa) + & - ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep - hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & - ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep + hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & + ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & + ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & @@ -3233,10 +3195,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) else ! ! bulk fluxes are in gC / m2 / s - hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & - ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep - hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & - ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep + hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & + ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & + ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & @@ -3428,7 +3390,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) integer :: ft ! functional type index integer :: scpf ! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array - real(r8) :: n_density ! individual of cohort per m2. real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8), parameter :: tiny = 1.e-5_r8 ! some small number real(r8) :: ncohort_scpf(nlevsclass*maxpft) ! Bins to count up cohorts counts used in weighting @@ -3592,10 +3553,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! TODO: we need a standardized logical function on this (used lots, RGK) if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) n_perm2 = ccohort%n/AREA else - n_density = 0.0_r8 n_perm2 = 0.0_r8 endif @@ -3799,18 +3758,18 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='TRIMMING', units='none', & long='Degree to which canopy expansion is limited by leaf economics', & use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_trimming_si) call this%set_history_var(vname='AREA_PLANT', units='m2', & long='area occupied by all plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_plant_si) call this%set_history_var(vname='AREA_TREES', units='m2', & long='area occupied by woody plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_trees_si) call this%set_history_var(vname='SITE_COLD_STATUS', units='0,1,2', & long='Site level cold status, 0=not cold-dec, 1=too cold for leaves, 2=not-too cold', & @@ -4119,54 +4078,54 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bstore_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bstore_si ) call this%set_history_var(vname='ED_bdead', units='gC m-2', & long='Dead (structural) biomass (live trees, not CWD)', & use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bdead_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bdead_si ) call this%set_history_var(vname='ED_balive', units='gC m-2', & long='Live biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_balive_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_balive_si ) call this%set_history_var(vname='ED_bleaf', units='gC m-2', & long='Leaf biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bleaf_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bleaf_si ) call this%set_history_var(vname='ED_bsapwood', units='gC m-2', & long='Sapwood biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bsapwood_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bsapwood_si ) call this%set_history_var(vname='ED_bfineroot', units='gC m-2', & long='Fine root biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bfineroot_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bfineroot_si ) call this%set_history_var(vname='ED_biomass', units='gC m-2', & long='Total biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_btotal_si ) call this%set_history_var(vname='AGB', units='gC m-2', & long='Aboveground biomass', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_agb_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_agb_si ) call this%set_history_var(vname='BIOMASS_CANOPY', units='gC m-2', & long='Biomass of canopy plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_si ) call this%set_history_var(vname='BIOMASS_UNDERSTORY', units='gC m-2', & long='Biomass of understory plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_si ) ! Canopy Resistance @@ -4183,35 +4142,30 @@ subroutine define_history_vars(this, initialize_variables) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) - call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & + call this%set_history_var(vname='NPP', units='gC/m^2/s', & long='net primary production on the site', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) call this%set_history_var(vname='GPP', units='gC/m^2/s', & long='gross primary production', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_pa ) - - call this%set_history_var(vname='NPP', units='gC/m^2/s', & - long='net primary production', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_si ) call this%set_history_var(vname='AR', units='gC/m^2/s', & long='autotrophic respiration', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_aresp_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_aresp_si ) call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & long='growth respiration', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_si ) call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & long='maintenance respiration', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_si ) ! Canopy resistance @@ -4239,23 +4193,23 @@ subroutine define_history_vars(this, initialize_variables) ! fast fluxes separated canopy/understory call this%set_history_var(vname='GPP_CANOPY', units='gC/m^2/s', & long='gross primary production of canopy plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si ) call this%set_history_var(vname='AR_CANOPY', units='gC/m^2/s', & long='autotrophic respiration of canopy plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si ) call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & long='gross primary production of understory plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si ) call this%set_history_var(vname='AR_UNDERSTORY', units='gC/m^2/s', & long='autotrophic respiration of understory plants', use_default='active', & - avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si ) ! fast radiative fluxes resolved through the canopy From c65614ee8508eec7299098119a4375e729a61b8e Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 29 Apr 2020 12:53:02 -0600 Subject: [PATCH 095/114] fixing long name of NPP var --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1fcad70616..640efa581e 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4143,7 +4143,7 @@ subroutine define_history_vars(this, initialize_variables) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) call this%set_history_var(vname='NPP', units='gC/m^2/s', & - long='net primary production on the site', use_default='active', & + long='net primary production', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) From 5ac1cebe44b441253df4bd8a5f4ba7c97764aebc Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Wed, 6 May 2020 10:36:57 -0700 Subject: [PATCH 096/114] Apply suggestions from code review Co-authored-by: jkshuman --- main/FatesHistoryInterfaceMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d854aaffb9..b1f45ebf0d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4075,7 +4075,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_si ) call this%set_history_var(vname='FIRE_INTENSITY_AREA_PRODUCT', units='kJ/m/s', & - long='spitfire product of fire intensity and burned area (divide by FIRE_AREA to get area-weifghted mean intensity)', & + long='spitfire product of fire intensity and burned area (divide by FIRE_AREA to get area-weighted mean intensity)', & use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_area_product_si ) @@ -4085,12 +4085,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_area_si ) - call this%set_history_var(vname='fire_fuel_mef', units='m', & + call this%set_history_var(vname='FIRE_FUEL_MEF', units='m', & long='spitfire fuel moisture', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_si ) - call this%set_history_var(vname='fire_fuel_bulkd', units='kg biomass/m3', & + call this%set_history_var(vname='FIRE_FUEL_BULKD', units='kg biomass/m3', & long='spitfire fuel bulk density', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_si ) @@ -4100,7 +4100,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si ) - call this%set_history_var(vname='fire_fuel_sav', units='per m', & + call this%set_history_var(vname='FIRE_FUEL_SAV', units='per m', & long='spitfire fuel surface/volume ', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_si ) @@ -5300,7 +5300,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) call this%set_history_var(vname='FIRE_FLUX', units='g/m^2/s', & - long='ED/SPitfire loss to atmosphere of elements', use_default='active', & + long='ED-spitfire loss to atmosphere of elements', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_burn_flux_elem ) From bed00be10ed064299f304b7140015692e48a01be Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 6 May 2020 15:13:32 -0600 Subject: [PATCH 097/114] cleaning up unused n_perm2 variable --- main/FatesHistoryInterfaceMod.F90 | 8 -------- 1 file changed, 8 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 640efa581e..054c0d747b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3390,7 +3390,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) integer :: ft ! functional type index integer :: scpf ! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array - real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8), parameter :: tiny = 1.e-5_r8 ! some small number real(r8) :: ncohort_scpf(nlevsclass*maxpft) ! Bins to count up cohorts counts used in weighting ! should be "hio_nplant_si_scpf" @@ -3551,13 +3550,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ccohort_hydr => ccohort%co_hydr - ! TODO: we need a standardized logical function on this (used lots, RGK) - if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then - n_perm2 = ccohort%n/AREA - else - n_perm2 = 0.0_r8 - endif - if ( .not. ccohort%isnew ) then ! Calculate index for the scpf class From 5f571930cdd919a291e8ff64162c2f5c99953170 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 May 2020 16:35:02 -0700 Subject: [PATCH 098/114] Split FatesInterfaceMod into two, routines and data --- biogeochem/EDCanopyStructureMod.F90 | 16 +- biogeochem/EDCohortDynamicsMod.F90 | 18 +- biogeochem/EDLoggingMortalityMod.F90 | 16 +- biogeochem/EDMortalityFunctionsMod.F90 | 14 +- biogeochem/EDPatchDynamicsMod.F90 | 14 +- biogeochem/EDPhysiologyMod.F90 | 26 +- biogeophys/EDAccumulateFluxesMod.F90 | 2 +- biogeophys/EDBtranMod.F90 | 4 +- biogeophys/EDSurfaceAlbedoMod.F90 | 8 +- biogeophys/FatesBstressMod.F90 | 4 +- biogeophys/FatesPlantHydraulicsMod.F90 | 222 +----- biogeophys/FatesPlantRespPhotosynthMod.F90 | 12 +- fire/SFMainMod.F90 | 12 +- main/ChecksBalancesMod.F90 | 4 +- main/EDInitMod.F90 | 106 +-- main/EDMainMod.F90 | 30 +- main/FatesGlobals.F90 | 3 +- main/FatesHistoryInterfaceMod.F90 | 26 +- main/FatesHydraulicsMemMod.F90 | 177 +++++ main/FatesInterfaceMod.F90 | 836 +++------------------ main/FatesInterfaceTypesMod.F90 | 698 +++++++++++++++++ main/FatesInventoryInitMod.F90 | 10 +- main/FatesParameterDerivedMod.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 26 +- main/FatesSizeAgeTypeIndicesMod.F90 | 8 +- 25 files changed, 1136 insertions(+), 1158 deletions(-) create mode 100644 main/FatesInterfaceTypesMod.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index acf7a9edd0..0e2de53919 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -24,10 +24,10 @@ module EDCanopyStructureMod use EDTypesMod , only : nlevleaf use EDtypesMod , only : AREA use FatesGlobals , only : endrun => fates_endrun - use FatesInterfaceMod , only : hlm_days_per_year - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_days_per_year + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch @@ -121,7 +121,7 @@ subroutine canopy_structure( currentSite , bc_in ) use EDParamsMod, only : ED_val_comp_excln use EDTypesMod , only : min_patch_area - use FatesInterfaceMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -1256,8 +1256,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! Much of this routine was once ed_clm_link minus all the IO and history stuff ! --------------------------------------------------------------------------------- - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use EDPatchDynamicsMod , only : set_patchno use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index @@ -1874,7 +1874,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA - use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceTypesMod , only : bc_out_type use EDPftvarcon , only : EDPftvarcon_inst diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 13a3068e51..f5659dca97 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -6,18 +6,18 @@ module EDCohortDynamicsMod ! !USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - use FatesInterfaceMod , only : hlm_freq_day - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : calloc_abs_error - use FatesInterfaceMod , only : hlm_days_per_year - use FatesInterfaceMod , only : nleafage + use FatesInterfaceTypesMod , only : hlm_days_per_year + use FatesInterfaceTypesMod , only : nleafage use SFParamsMod , only : SF_val_CWD_frac use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac @@ -38,8 +38,8 @@ module EDCohortDynamicsMod use EDTypesMod , only : site_fluxdiags_type use EDTypesMod , only : num_elements use EDParamsMod , only : ED_val_cohort_age_fusion_tol - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_parteh_mode + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_parteh_mode use FatesPlantHydraulicsMod, only : FuseCohortHydraulics use FatesPlantHydraulicsMod, only : CopyCohortHydraulics use FatesPlantHydraulicsMod, only : UpdateSizeDepPlantHydProps @@ -953,7 +953,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! !USES: use EDParamsMod , only : ED_val_cohort_size_fusion_tol use EDParamsMod , only : ED_val_cohort_age_fusion_tol - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesConstantsMod , only : itrue use FatesConstantsMod, only : days_per_year use EDTypesMod , only : maxCohortsPerPatch diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index f8c9a4cef8..060a156f39 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -38,14 +38,14 @@ module EDLoggingMortalityMod use EDParamsMod , only : logging_mechanical_frac use EDParamsMod , only : logging_coll_under_frac use EDParamsMod , only : logging_dbhmax_infra - use FatesInterfaceMod , only : hlm_current_year - use FatesInterfaceMod , only : hlm_current_month - use FatesInterfaceMod , only : hlm_current_day - use FatesInterfaceMod , only : hlm_model_day - use FatesInterfaceMod , only : hlm_day_of_year - use FatesInterfaceMod , only : hlm_days_per_year - use FatesInterfaceMod , only : hlm_use_logging - use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_current_year + use FatesInterfaceTypesMod , only : hlm_current_month + use FatesInterfaceTypesMod , only : hlm_current_day + use FatesInterfaceTypesMod , only : hlm_model_day + use FatesInterfaceTypesMod , only : hlm_day_of_year + use FatesInterfaceTypesMod , only : hlm_days_per_year + use FatesInterfaceTypesMod , only : hlm_use_logging + use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesConstantsMod , only : itrue,ifalse use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index af6334e71e..567094d98b 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -13,13 +13,13 @@ module EDMortalityFunctionsMod use FatesConstantsMod , only : itrue,ifalse use FatesAllometryMod , only : bleaf use FatesAllometryMod , only : storage_fraction_of_target - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_use_ed_prescribed_phys - use FatesInterfaceMod , only : hlm_freq_day - use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys + use FatesInterfaceTypesMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : hlm_use_planthydro use EDLoggingMortalityMod , only : LoggingMortality_frac use EDParamsMod , only : fates_mortality_disturbance_fraction - use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_in_type use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : store_organ @@ -50,7 +50,7 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor ! ============================================================================ use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use FatesInterfaceMod , only : hlm_hio_ignore_val + use FatesInterfaceTypesMod , only : hlm_hio_ignore_val use FatesConstantsMod, only : fates_check_param_set type (ed_cohort_type), intent(in) :: cohort_in @@ -217,7 +217,7 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in) ! ! !USES: - use FatesInterfaceMod, only : hlm_freq_day + use FatesInterfaceTypesMod, only : hlm_freq_day ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c57b8b3d6a..2998fd85d8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -4,7 +4,7 @@ module EDPatchDynamicsMod ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ use FatesGlobals , only : fates_log - use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : hlm_freq_day use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort @@ -37,11 +37,11 @@ module EDPatchDynamicsMod use EDTypesMod , only : dl_sf use EDTypesMod , only : dump_patch use FatesConstantsMod , only : rsnbl_math_prec - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_numSWb - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_days_per_year - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_numSWb + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_days_per_year + use FatesInterfaceTypesMod , only : numpft use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -75,7 +75,7 @@ module EDPatchDynamicsMod use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ use PRTLossFluxesMod, only : PRTBurnLosses - use FatesInterfaceMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_parteh_mode use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3e11d37aa9..0b5f977a30 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -7,21 +7,21 @@ module EDPhysiologyMod ! ============================================================================ use FatesGlobals, only : fates_log - use FatesInterfaceMod, only : hlm_days_per_year - use FatesInterfaceMod, only : hlm_model_day - use FatesInterfaceMod, only : hlm_freq_day - use FatesInterfaceMod, only : hlm_day_of_year - use FatesInterfaceMod, only : numpft - use FatesInterfaceMod, only : nleafage - use FatesInterfaceMod, only : hlm_use_planthydro - use FatesInterfaceMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_days_per_year + use FatesInterfaceTypesMod, only : hlm_model_day + use FatesInterfaceTypesMod, only : hlm_freq_day + use FatesInterfaceTypesMod, only : hlm_day_of_year + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : nleafage + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : g_per_kg use FatesConstantsMod, only : days_per_sec use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac - use FatesInterfaceMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use EDCohortDynamicsMod , only : zero_cohort use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject @@ -1422,7 +1422,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! spawn new cohorts of juveniles of each PFT ! ! !USES: - use FatesInterfaceMod, only : hlm_use_ed_prescribed_phys + use FatesInterfaceTypesMod, only : hlm_use_ed_prescribed_phys ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -2226,9 +2226,9 @@ subroutine FluxIntoLitterPools(nsites, sites, bc_in, bc_out) use EDTypesMod, only : AREA use FatesConstantsMod, only : sec_per_day - use FatesInterfaceMod, only : bc_in_type, bc_out_type - use FatesInterfaceMod, only : hlm_use_vertsoilc - use FatesInterfaceMod, only : hlm_numlevgrnd + use FatesInterfaceTypesMod, only : bc_in_type, bc_out_type + use FatesInterfaceTypesMod, only : hlm_use_vertsoilc + use FatesInterfaceTypesMod, only : hlm_numlevgrnd use FatesConstantsMod, only : itrue use FatesGlobals, only : endrun => fates_endrun use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 37ac96df52..4d873cca85 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -39,7 +39,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA - use FatesInterfaceMod , only : bc_in_type,bc_out_type + use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type ! ! !ARGUMENTS diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 90d2b3f3c3..76bd1425c1 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -13,10 +13,10 @@ module EDBtranMod ed_cohort_type, & maxpft use shr_kind_mod , only : r8 => shr_kind_r8 - use FatesInterfaceMod , only : bc_in_type, & + use FatesInterfaceTypesMod , only : bc_in_type, & bc_out_type, & numpft - use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesGlobals , only : fates_log use FatesAllometryMod , only : set_root_fraction use FatesAllometryMod , only : i_hydro_rootprof_context diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d9e4c6b3f2..4e5309ea61 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -16,10 +16,10 @@ module EDSurfaceRadiationMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue use FatesConstantsMod , only : pi_const - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type - use FatesInterfaceMod , only : hlm_numSWb - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type + use FatesInterfaceTypesMod , only : hlm_numSWb + use FatesInterfaceTypesMod , only : numpft use EDTypesMod , only : maxSWb use EDTypesMod , only : nclmax use EDTypesMod , only : nlevleaf diff --git a/biogeophys/FatesBstressMod.F90 b/biogeophys/FatesBstressMod.F90 index 10d6777cc3..b4e81adcdc 100644 --- a/biogeophys/FatesBstressMod.F90 +++ b/biogeophys/FatesBstressMod.F90 @@ -12,10 +12,10 @@ module FatesBstressMod ed_cohort_type, & maxpft use shr_kind_mod , only : r8 => shr_kind_r8 - use FatesInterfaceMod , only : bc_in_type, & + use FatesInterfaceTypesMod , only : bc_in_type, & bc_out_type, & numpft - use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesGlobals , only : fates_log use EDBtranMod , only : check_layer_water use FatesAllometryMod , only : set_root_fraction diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index f926c64741..ae73b6acb8 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -55,12 +55,12 @@ module FatesPlantHydraulicsMod use EDTypesMod , only : AREA use EDTypesMod , only : leaves_on - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_ipedof - use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : nlevsclass + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_ipedof + use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : nlevsclass use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom @@ -90,6 +90,14 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 + use FateshydraulicsMemMod, only: wrf_plant, wkf_plant + use FateshydraulicsMemMod, only: alpha_vg + use FateshydraulicsMemMod, only: th_sat_vg + use FateshydraulicsMemMod, only: th_res_vg + use FateshydraulicsMemMod, only: psd_vg + use FateshydraulicsMemMod, only: tort_vg +! use FateshydraulicsMemMod, only: + use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ @@ -175,35 +183,7 @@ module FatesPlantHydraulicsMod __FILE__ - integer, public, parameter :: van_genuchten_type = 1 - integer, public, parameter :: campbell_type = 2 - integer, public, parameter :: tfs_type = 3 - - integer, parameter :: plant_wrf_type = tfs_type - integer, parameter :: plant_wkf_type = tfs_type - integer, parameter :: soil_wrf_type = campbell_type - integer, parameter :: soil_wkf_type = campbell_type - - - ! Define the global object that holds the water retention functions - ! for plants of each different porous media type, and plant functional type - - class(wrf_arr_type),pointer :: wrf_plant(:,:) - - ! Define the global object that holds the water conductance functions - ! for plants of each different porous media type, and plant functional type - - class(wkf_arr_type), pointer :: wkf_plant(:,:) - - ! Testing parameters for Van Genuchten soil WRTs - ! unused unless van_genuchten_type is selected, also - ! it would be much better to use the native parameters passed in - ! from the HLM's soil model - real(r8), parameter :: alpha_vg = 0.001_r8 - real(r8), parameter :: th_sat_vg = 0.65_r8 - real(r8), parameter :: th_res_vg = 0.15_r8 - real(r8), parameter :: psd_vg = 2.7_r8 - real(r8), parameter :: tort_vg = 0.5_r8 + ! The maximum allowable water balance error over a plant-soil continuum ! for a given step [kgs] (0.1 mg) @@ -235,7 +215,7 @@ module FatesPlantHydraulicsMod public :: UpdatePlantHydrLenVol public :: UpdatePlantKmax public :: ConstrainRecruitNumber - public :: InitHydroGlobals + !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen @@ -5194,174 +5174,4 @@ end subroutine SetMaxCondConnections ! ===================================================================================== - subroutine InitHydroGlobals() - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_tfs), pointer :: wkf_tfs - class(wrf_type_tfs), pointer :: wrf_tfs - - integer :: ft ! PFT index - integer :: pm ! plant media index - integer :: inode ! compartment node index - real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) - real(r8) :: cap_slp ! slope of capillary region of curve - real(r8) :: cap_int ! intercept of capillary region of curve - - if(hlm_use_planthydro.eq.ifalse) return - - ! we allocate from stomata_p_media, which should be zero - - allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) - allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wrf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wrf_vg) - wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - end do - case(campbell_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_cch) - wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - 9._r8]) - end do - end do - case(tfs_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_tfs) - wrf_plant(pm,ft)%p => wrf_tfs - - if (pm.eq.leaf_p_media) then ! Leaf tissue - cap_slp = 0.0_r8 - cap_int = 0.0_r8 - cap_corr = 1.0_r8 - else ! Non leaf tissues - cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int = -cap_slp + hydr_psi0 - cap_corr = -cap_int/cap_slp - end if - - call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_resid_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - EDPftvarcon_inst%hydr_epsil_node(ft,pm), & - rwcft(pm), & - cap_corr, & - cap_int, & - cap_slp,real(pm,r8)]) - end do - end do - - end select - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wkf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_vg) - wkf_plant(pm,ft)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - - end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_tfs) - wkf_plant(pm,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & - EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) - end do - end do - end select - - ! There is only 1 stomata conductance hypothesis which uses the p50 and - ! vulnerability parameters - ! ----------------------------------------------------------------------------------- - - do ft = 1,numpft - allocate(wkf_tfs) - wkf_plant(stomata_p_media,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & - EDPftvarcon_inst%hydr_avuln_gs(ft)]) - end do - - - return - end subroutine InitHydroGlobals - - !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) - - ! This code may be re-introduced at a later date (rgk 08-2019) - - ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP - ! first update the leaf water potential memory - !! do t=2, numLWPmem - !!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) - !!end do - !!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) - !!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - - !!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 - !!do k=1,n_hypool_ag - !!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) - !!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling - !! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & - !! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do k=1,n_hypool_troot - !!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) - !!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling - !! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & - !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do j=1,site_hydr%nlevrhiz - !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) - !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling - !! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & - !! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) - !!end if - !!end do - !!end subroutine UpdateLWPMemFLCMin - - - end module FatesPlantHydraulicsMod diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 59531574de..0f2d32a5dd 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -26,10 +26,10 @@ module FATESPlantRespPhotosynthMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : itrue use FatesConstantsMod, only : nearzero - use FatesInterfaceMod, only : hlm_use_planthydro - use FatesInterfaceMod, only : hlm_parteh_mode - use FatesInterfaceMod, only : numpft - use FatesInterfaceMod, only : nleafage + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : nleafage use EDTypesMod, only : maxpft use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax @@ -89,8 +89,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_site_type use EDTypesMod , only : maxpft use EDTypesMod , only : dinc_ed - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type use EDCanopyStructureMod, only : calc_areaindex use FatesConstantsMod, only : umolC_to_kgC use FatesConstantsMod, only : g_per_kg diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index c015db7131..ac4f672608 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -7,11 +7,11 @@ module SFMainMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse - use FatesInterfaceMod , only : hlm_masterproc ! 1= master process, 0=not master process + use FatesInterfaceTypesMod , only : hlm_masterproc ! 1= master process, 0=not master process use EDTypesMod , only : numWaterMem use FatesGlobals , only : fates_log - use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_in_type use EDPftvarcon , only : EDPftvarcon_inst @@ -40,7 +40,7 @@ module SFMainMod use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : numpft implicit none private @@ -70,7 +70,7 @@ module SFMainMod ! ============================================================================ subroutine fire_model( currentSite, bc_in) - use FatesInterfaceMod, only : hlm_use_spitfire + use FatesInterfaceTypesMod, only : hlm_use_spitfire type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -419,7 +419,7 @@ subroutine rate_of_spread ( currentSite ) SF_val_miner_damp, & SF_val_fuel_energy - use FatesInterfaceMod, only : hlm_current_day, hlm_current_month + use FatesInterfaceTypesMod, only : hlm_current_day, hlm_current_month type(ed_site_type), intent(in), target :: currentSite @@ -662,7 +662,7 @@ subroutine area_burnt_intensity ( currentSite ) !currentPatch%ROS_front forward ROS (m/min) !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) - use FatesInterfaceMod, only : hlm_use_spitfire + use FatesInterfaceTypesMod, only : hlm_use_spitfire use EDParamsMod, only : ED_val_nignitions use EDParamsMod, only : cg_strikes ! fraction of cloud-to-ground ligtning strikes use FatesConstantsMod, only : years_per_day diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 index 72d9288a51..9374c373e0 100644 --- a/main/ChecksBalancesMod.F90 +++ b/main/ChecksBalancesMod.F90 @@ -9,9 +9,9 @@ module ChecksBalancesMod use EDTypesMod, only : site_massbal_type use EDTypesMod, only : num_elements use EDTypesMod, only : element_list - use FatesInterfaceMod, only : numpft + use FatesInterfaceTypesMod, only : numpft use FatesConstantsMod, only : g_per_kg - use FatesInterfaceMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8ec32c173d..1098e8eda5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -12,7 +12,7 @@ module EDInitMod use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log - use FatesInterfaceMod , only : hlm_is_restart + use FatesInterfaceTypesMod , only : hlm_is_restart use EDPftvarcon , only : EDPftvarcon_inst use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject @@ -36,13 +36,13 @@ module EDInitMod use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : element_pos - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_inventory_init - use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : nleafage - use FatesInterfaceMod , only : nlevsclass - use FatesInterfaceMod , only : nlevcoage + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_inventory_init + use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : nleafage + use FatesInterfaceTypesMod , only : nlevsclass + use FatesInterfaceTypesMod , only : nlevcoage use FatesAllometryMod , only : h2d_allom use FatesAllometryMod , only : bagw_allom use FatesAllometryMod , only : bbgw_allom @@ -52,7 +52,7 @@ module EDInitMod use FatesAllometryMod , only : bdead_allom use FatesAllometryMod , only : bstore_allom - use FatesInterfaceMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_parteh_mode use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTGenericMod, only : prt_vartypes @@ -66,7 +66,7 @@ module EDInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState - use FatesPlantHydraulicsMod, only : InitHydroGlobals +!! use FatesPlantHydraulicsMod, only : InitHydroGlobals use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon ! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP @@ -93,92 +93,6 @@ module EDInitMod contains - ! ============================================================================ - - ! ==================================================================================== - - subroutine InitFatesGlobals(masterproc) - - ! -------------------------------------------------------------------------- - ! This subroutine is simply a wrapper that calls various FATES modules - ! that initialize global objects, things, constructs, etc. Globals only - ! need to be set once during initialization, for each machine, and this - ! should not be called for forked SMP processes. - ! -------------------------------------------------------------------------- - - logical,intent(in) :: masterproc ! This is useful for reporting - ! and diagnostics so info is not printed - ! on numerous nodes to standard out. This - ! is not used to filter which machines - ! (nodes) to run these procedures, they - ! should be run on ALL nodes. - - ! Initialize PARTEH globals - ! (like the element lists, and mapping tables) - call InitPARTEHGlobals() - - ! Initialize Hydro globals - ! (like water retention functions) - call InitHydroGlobals() - - - return - end subroutine InitFatesGlobals - - ! ==================================================================================== - - - subroutine InitPARTEHGlobals() - - ! Initialize the Plant Allocation and Reactive Transport - ! global functions and mapping tables - ! Also associate the elements defined in PARTEH with a list in FATES - ! "element_list" is useful because it allows the fates side of the code - ! to loop through elements, and call the correct PARTEH interfaces - ! automatically. - - select case(hlm_parteh_mode) - case(prt_carbon_allom_hyp) - - num_elements = 1 - allocate(element_list(num_elements)) - element_list(1) = carbon12_element - element_pos(:) = 0 - element_pos(carbon12_element) = 1 - - call InitPRTGlobalAllometricCarbon() - - case(prt_cnp_flex_allom_hyp) - - num_elements = 3 - allocate(element_list(num_elements)) - element_list(1) = carbon12_element - element_list(2) = nitrogen_element - element_list(3) = phosphorus_element - element_pos(:) = 0 - element_pos(carbon12_element) = 1 - element_pos(nitrogen_element) = 2 - element_pos(phosphorus_element) = 3 - - !call InitPRTGlobalAllometricCNP() - write(fates_log(),*) 'You specified the allometric CNP mode' - write(fates_log(),*) 'with relaxed target stoichiometry.' - write(fates_log(),*) 'I.e., namelist parametre fates_parteh_mode = 2' - write(fates_log(),*) 'This mode is not available yet. Please set it to 1.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - case DEFAULT - write(fates_log(),*) 'You specified an unknown PRT module' - write(fates_log(),*) 'Check your setting for fates_parteh_mode' - write(fates_log(),*) 'in the CLM namelist. The only valid value now is 1' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end select - - end subroutine InitPARTEHGlobals - - ! ============================================================================ subroutine init_site_vars( site_in, bc_in ) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 31f9d930e8..c2913ca0a1 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -8,20 +8,20 @@ module EDMainMod use shr_kind_mod , only : r8 => shr_kind_r8 use FatesGlobals , only : fates_log - use FatesInterfaceMod , only : hlm_freq_day - use FatesInterfaceMod , only : hlm_day_of_year - use FatesInterfaceMod , only : hlm_days_per_year - use FatesInterfaceMod , only : hlm_current_year - use FatesInterfaceMod , only : hlm_current_month - use FatesInterfaceMod , only : hlm_current_day - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking - use FatesInterfaceMod , only : hlm_reference_date - use FatesInterfaceMod , only : hlm_use_ed_prescribed_phys - use FatesInterfaceMod , only : hlm_use_ed_st3 - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_masterproc - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : hlm_day_of_year + use FatesInterfaceTypesMod , only : hlm_days_per_year + use FatesInterfaceTypesMod , only : hlm_current_year + use FatesInterfaceTypesMod , only : hlm_current_month + use FatesInterfaceTypesMod , only : hlm_current_day + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_reference_date + use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys + use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_masterproc + use FatesInterfaceTypesMod , only : numpft use EDCohortDynamicsMod , only : terminate_cohorts use EDCohortDynamicsMod , only : fuse_cohorts use EDCohortDynamicsMod , only : sort_cohorts @@ -280,7 +280,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! FIX(SPM,032414) refactor so everything goes through interface ! ! !USES: - use FatesInterfaceMod, only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod, only : hlm_use_cohort_age_tracking use FatesConstantsMod, only : itrue ! !ARGUMENTS: diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 260b3a9313..d37ffe3b2a 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -67,7 +67,6 @@ subroutine fates_endrun(msg) end subroutine fates_endrun ! ===================================================================================== - - + end module FatesGlobals diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 51db184e95..4da22e4ef0 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -27,19 +27,19 @@ module FatesHistoryInterfaceMod use FatesIODimensionsMod , only : fates_io_dimension_type use FatesIOVariableKindMod , only : fates_io_variable_kind_type use FatesHistoryVariableType , only : fates_history_variable_type - use FatesInterfaceMod , only : hlm_hio_ignore_val - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_ed_st3 - use FatesInterfaceMod , only : hlm_use_cohort_age_tracking - use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : hlm_hio_ignore_val + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_freq_day use EDParamsMod , only : ED_val_comp_excln use EDParamsMod , only : ED_val_phen_coldtemp - use FatesInterfaceMod , only : nlevsclass, nlevage - use FatesInterfaceMod , only : nlevheight - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_model_day - use FatesInterfaceMod , only : nlevcoage + use FatesInterfaceTypesMod , only : nlevsclass, nlevage + use FatesInterfaceTypesMod , only : nlevheight + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : hlm_model_day + use FatesInterfaceTypesMod , only : nlevcoage ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst @@ -1376,7 +1376,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype hlms, flushval, upfreq, ivar, initialize, index) use FatesUtilsMod, only : check_hlm_list - use FatesInterfaceMod, only : hlm_name + use FatesInterfaceTypesMod, only : hlm_name implicit none @@ -3765,7 +3765,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_pft_r8, site_coage_r8 use FatesIOVariableKindMod, only : site_height_r8 - use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9d5c18bfa5..68793aeb1e 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -64,6 +64,37 @@ module FatesHydraulicsMemMod ! Should we ignore the first soil layer and have root layers start on the second? logical, parameter, public :: ignore_layer1=.true. + + integer, public, parameter :: van_genuchten_type = 1 + integer, public, parameter :: campbell_type = 2 + integer, public, parameter :: tfs_type = 3 + + integer, parameter :: plant_wrf_type = tfs_type + integer, parameter :: plant_wkf_type = tfs_type + integer, parameter :: soil_wrf_type = campbell_type + integer, parameter :: soil_wkf_type = campbell_type + + + ! Define the global object that holds the water retention functions + ! for plants of each different porous media type, and plant functional type + + class(wrf_arr_type),pointer :: wrf_plant(:,:) + + ! Define the global object that holds the water conductance functions + ! for plants of each different porous media type, and plant functional type + + class(wkf_arr_type), pointer :: wkf_plant(:,:) + + ! Testing parameters for Van Genuchten soil WRTs + ! unused unless van_genuchten_type is selected, also + ! it would be much better to use the native parameters passed in + ! from the HLM's soil model + real(r8), parameter :: alpha_vg = 0.001_r8 + real(r8), parameter :: th_sat_vg = 0.65_r8 + real(r8), parameter :: th_res_vg = 0.15_r8 + real(r8), parameter :: psd_vg = 2.7_r8 + real(r8), parameter :: tort_vg = 0.5_r8 + ! Derived parameters @@ -74,6 +105,10 @@ module FatesHydraulicsMemMod ! single individual at different layer (kg H2o/m2) real(r8), public :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) + + public :: InitHydroGlobals + + type, public :: ed_site_hydr_type ! Plant Hydraulics @@ -577,6 +612,148 @@ subroutine SetConnections(this) end if end subroutine SetConnections + + ! ==================================================================================== + + subroutine InitHydroGlobals(numpft) + + use FatesHydroWTFMod, only : wrf_arr_type + use FatesHydroWTFMod, only : wkf_arr_type + use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs + use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs + use EDPftvarcon, only : EDPftvarcon_inst + use EDParamsMod, only : hydr_psi0 + use EDParamsMod, only : hydr_psicap + + + ! This routine allocates the Water Transfer Functions (WTFs) + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for plants! These functions have specific + ! parameters, potentially, for each plant functional type and + ! each organ (pft x organ), but this can be used globally (across + ! all sites on the node (machine) to save memory. These functions + ! are also applied to soils, but since soil properties vary with + ! soil layer and location, those functions are bound to the site + ! structure, and are therefore not "global". + + integer,intent(in) :: numpft + + ! Define + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_tfs), pointer :: wkf_tfs + class(wrf_type_tfs), pointer :: wrf_tfs + + integer :: ft ! PFT index + integer :: pm ! plant media index + integer :: inode ! compartment node index + real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) + real(r8) :: cap_slp ! slope of capillary region of curve + real(r8) :: cap_int ! intercept of capillary region of curve + + if(hlm_use_planthydro.eq.ifalse) return + ! we allocate from stomata_p_media, which should be zero + + allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) + allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wrf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + end do + case(campbell_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_cch) + wrf_plant(pm,ft)%p => wrf_cch + call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + 9._r8]) + end do + end do + case(tfs_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if + + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) + end do + end do + + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wkf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + + end do + case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + end do + end select + + ! There is only 1 stomata conductance hypothesis which uses the p50 and + ! vulnerability parameters + ! ----------------------------------------------------------------------------------- + + do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) + end do + + + return + end subroutine InitHydroGlobals + end module FatesHydraulicsMemMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d72f2b5cd6..207b0f09fe 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -38,590 +38,21 @@ module FatesInterfaceMod use EDParamsMod , only : bgc_soil_salinity use PRTGenericMod , only : prt_carbon_allom_hyp use PRTGenericMod , only : prt_cnp_flex_allom_hyp - + use HydraulicsMemMod , only : InitHydroGlobals + use EDParamsMod, only : ED_val_history_sizeclass_bin_edges, ED_val_history_ageclass_bin_edges + use EDParamsMod, only : ED_val_history_height_bin_edges + use EDParamsMod, only : ED_val_history_coageclass_bin_edges + use CLMFatesParamInterfaceMod , only : FatesReadParameters + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - implicit none - - private ! By default everything is private - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - - ! ------------------------------------------------------------------------------------- - ! Parameters that are dictated by the Host Land Model - ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. - ! ------------------------------------------------------------------------------------- - - - integer, public, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation - ! specturm to track - ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - - integer, public, protected :: hlm_ivis ! The HLMs assumption of the array index associated with the - ! visible portion of the spectrum in short-wave radiation arrays - - integer, public, protected :: hlm_inir ! The HLMs assumption of the array index associated with the - ! NIR portion of the spectrum in short-wave radiation arrays - - - integer, public, protected :: hlm_numlevgrnd ! Number of ground layers - ! NOTE! SOIL LAYERS ARE NOT A GLOBAL, THEY - ! ARE VARIABLE BY SITE - - integer, public, protected :: hlm_is_restart ! Is the HLM signalling that this is a restart - ! type simulation? - ! 1=TRUE, 0=FALSE - - character(len=16), public, protected :: hlm_name ! This character string passed by the HLM - ! is used during the processing of IO data, - ! so that FATES knows which IO variables it - ! should prepare. For instance - ! ATS, ALM and CLM will only want variables - ! specficially packaged for them. - ! This string sets which filter is enacted. - - - real(r8), public, protected :: hlm_hio_ignore_val ! This value can be flushed to history - ! diagnostics, such that the - ! HLM will interpret that the value should not - ! be included in the average. - - integer, public, protected :: hlm_masterproc ! Is this the master processor, typically useful - ! for knowing if the current machine should be - ! printing out messages to the logs or terminals - ! 1 = TRUE (is master) 0 = FALSE (is not master) - - integer, public, protected :: hlm_ipedof ! The HLM pedotransfer index - ! this is only used by the plant hydraulics - ! submodule to check and/or enable consistency - ! between the pedotransfer functions of the HLM - ! and how it moves and stores water in its - ! rhizosphere shells - - integer, public, protected :: hlm_max_patch_per_site ! The HLM needs to exchange some patch - ! level quantities with FATES - ! FATES does not dictate those allocations - ! since it happens pretty early in - ! the model initialization sequence. - ! So we want to at least query it, - ! compare it to our maxpatchpersite, - ! and gracefully halt if we are over-allocating - - integer, public, protected :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive - ! Transport (exensible) Hypothesis (PARTEH) to use - - - integer, public, protected :: hlm_use_vertsoilc ! This flag signals whether or not the - ! host model is using vertically discretized - ! soil carbon - ! 1 = TRUE, 0 = FALSE - - integer, public, protected :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE - ! 1 = TRUE, 0 = FALSE - - - integer, public, protected :: hlm_use_logging ! This flag signals whether or not to use - ! the logging module - - integer, public, protected :: hlm_use_planthydro ! This flag signals whether or not to use - ! plant hydraulics (bchristo/xu methods) - ! 1 = TRUE, 0 = FALSE - ! THIS IS CURRENTLY NOT SUPPORTED - - integer, public, protected :: hlm_use_cohort_age_tracking ! This flag signals whether or not to use - ! cohort age tracking. 1 = TRUE, 0 = FALSE - - integer, public, protected :: hlm_use_ed_st3 ! This flag signals whether or not to use - ! (ST)atic (ST)and (ST)ructure mode (ST3) - ! Essentially, this gives us the ability - ! to turn off "dynamics", ie growth, disturbance - ! recruitment and mortality. - ! (EXPERIMENTAL!!!!! - RGK 07-2017) - ! 1 = TRUE, 0 = FALSE - ! default should be FALSE (dynamics on) - ! cannot be true with prescribed_phys - - integer, public, protected :: hlm_use_ed_prescribed_phys ! This flag signals whether or not to use - ! prescribed physiology, somewhat the opposite - ! to ST3, in this case can turn off - ! fast processes like photosynthesis and respiration - ! and prescribe NPP - ! (NOT CURRENTLY IMPLEMENTED - PLACEHOLDER) - ! 1 = TRUE, 0 = FALSE - ! default should be FALSE (biophysics on) - ! cannot be true with st3 mode - - integer, public, protected :: hlm_use_inventory_init ! Initialize this simulation from - ! an inventory file. If this is toggled on - ! an inventory control file must be specified - ! as well. - ! 1 = TRUE, 0 = FALSE - - character(len=256), public, protected :: hlm_inventory_ctrl_file ! This is the full path to the - ! inventory control file that - ! specifieds the availabel inventory datasets - ! there locations and their formats - ! This need only be defined when - ! hlm_use_inventory_init = 1 - - ! ------------------------------------------------------------------------------------- - ! Parameters that are dictated by FATES and known to be required knowledge - ! needed by the HLMs - ! ------------------------------------------------------------------------------------- - - ! Variables mostly used for dimensioning host land model (HLM) array spaces - - integer, public, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately - ! used to set the size of the largest arrays necessary - ! in things like restart files (probably hosted by the - ! HLM). The size of these arrays are not a parameter - ! because it is simply the maximum of several different - ! dimensions. It is possible that this would be the - ! maximum number of cohorts per patch, but - ! but it could be other things. - - integer, public, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per - ! each grid cell and effects the striding in the ED restart - ! data as some fields are arrays where each array is - ! associated with one cohort - - ! ------------------------------------------------------------------------------------- - ! These vectors are used for history output mapping - ! CLM/ALM have limited support for multi-dimensional history output arrays. - ! FATES structure and composition is multi-dimensional, so we end up "multi-plexing" - ! multiple dimensions into one dimension. These new dimensions need definitions, - ! mapping to component dimensions, and definitions for those component dimensions as - ! well. - ! ------------------------------------------------------------------------------------- - - real(r8), public, allocatable :: fates_hdim_levcoage(:) ! cohort age class lower bound dimension - integer , public, allocatable :: fates_hdim_pfmap_levcapf(:) ! map of pfts into cohort age class x pft dimension - integer , public, allocatable :: fates_hdim_camap_levcapf(:) ! map of cohort age class into cohort age x pft dimension - - - real(r8), public, allocatable :: fates_hdim_levsclass(:) ! plant size class lower bound dimension - integer , public, allocatable :: fates_hdim_pfmap_levscpf(:) ! map of pfts into size-class x pft dimension - integer , public, allocatable :: fates_hdim_scmap_levscpf(:) ! map of size-class into size-class x pft dimension - real(r8), public, allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension - real(r8), public, allocatable :: fates_hdim_levheight(:) ! height lower bound dimension - integer , public, allocatable :: fates_hdim_levpft(:) ! plant pft dimension - integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel class dimension - integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension - integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension - integer , public, allocatable :: fates_hdim_levelem(:) ! element dimension - integer , public, allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dim - integer , public, allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the can-layer x leaf-layer dimension - integer , public, allocatable :: fates_hdim_canmap_levcnlfpf(:) ! can-layer map into the can-layer x pft x leaf-layer dim - integer , public, allocatable :: fates_hdim_lfmap_levcnlfpf(:) ! leaf-layer map into the can-layer x pft x leaf-layer dim - integer , public, allocatable :: fates_hdim_pftmap_levcnlfpf(:) ! pft map into the canopy-layer x pft x leaf-layer dim - integer , public, allocatable :: fates_hdim_scmap_levscag(:) ! map of size-class into size-class x patch age dimension - integer , public, allocatable :: fates_hdim_agmap_levscag(:) ! map of patch-age into size-class x patch age dimension - integer , public, allocatable :: fates_hdim_scmap_levscagpft(:) ! map of size-class into size-class x patch age x pft dimension - integer , public, allocatable :: fates_hdim_agmap_levscagpft(:) ! map of patch-age into size-class x patch age x pft dimension - integer , public, allocatable :: fates_hdim_pftmap_levscagpft(:) ! map of pft into size-class x patch age x pft dimension - integer , public, allocatable :: fates_hdim_agmap_levagepft(:) ! map of patch-age into patch age x pft dimension - integer , public, allocatable :: fates_hdim_pftmap_levagepft(:) ! map of pft into patch age x pft dimension - - integer , public, allocatable :: fates_hdim_elmap_levelpft(:) ! map of elements in the element x pft dimension - integer , public, allocatable :: fates_hdim_elmap_levelcwd(:) ! map of elements in the element x cwd dimension - integer , public, allocatable :: fates_hdim_elmap_levelage(:) ! map of elements in the element x age dimension - integer , public, allocatable :: fates_hdim_pftmap_levelpft(:) ! map of pfts in the element x pft dimension - integer , public, allocatable :: fates_hdim_cwdmap_levelcwd(:) ! map of cwds in the element x cwd dimension - integer , public, allocatable :: fates_hdim_agemap_levelage(:) ! map of ages in the element x age dimension - - ! ------------------------------------------------------------------------------------ - ! DYNAMIC BOUNDARY CONDITIONS - ! ------------------------------------------------------------------------------------ - - - ! ------------------------------------------------------------------------------------- - ! Scalar Timing Variables - ! It is assumed that all of the sites on a given machine will be synchronous. - ! It is also assumed that the HLM will control time. - ! ------------------------------------------------------------------------------------- - integer, public, protected :: hlm_current_year ! Current year - integer, public, protected :: hlm_current_month ! month of year - integer, public, protected :: hlm_current_day ! day of month - integer, public, protected :: hlm_current_tod ! time of day (seconds past 0Z) - integer, public, protected :: hlm_current_date ! time of day (seconds past 0Z) - integer, public, protected :: hlm_reference_date ! YYYYMMDD - real(r8), public, protected :: hlm_model_day ! elapsed days between current date and ref - integer, public, protected :: hlm_day_of_year ! The integer day of the year - integer, public, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may - ! include a leap - real(r8), public, protected :: hlm_freq_day ! fraction of year for daily time-step - ! (1/days_per_year_, this is a frequency - - - ! ------------------------------------------------------------------------------------- - ! - ! Constant parameters that are dictated by the fates parameter file - ! - ! ------------------------------------------------------------------------------------- - - integer, public, protected :: numpft ! The total number of PFTs defined in the simulation - integer, public, protected :: nlevsclass ! The total number of cohort size class bins output to history - integer, public, protected :: nlevage ! The total number of patch age bins output to history - integer, public, protected :: nlevheight ! The total number of height bins output to history - integer, public, protected :: nlevcoage ! The total number of cohort age bins output to history - integer, public, protected :: nleafage ! The total number of leaf age classes - - ! ------------------------------------------------------------------------------------- - ! Structured Boundary Conditions (SITE/PATCH SCALE) - ! For floating point arrays, it is sometimes the convention to define the arrays as - ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle - ! differences. POINTER arrays can point to scalar values, discontinuous array slices - ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel - ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point - ! to contiguous memory spaces and do not alias other variables, the case here. - ! Naming conventions: _si means site dimensions (scalar in that case) - ! _pa means patch dimensions - ! _rb means radiation band - ! _sl means soil layer - ! _sisl means site x soil layer - ! ------------------------------------------------------------------------------------ - - type, public :: bc_in_type - - ! The actual number of FATES' ED patches - integer :: npatches - - - ! Soil layer structure - - integer :: nlevsoil ! the number of soil layers in this column - integer :: nlevdecomp ! the number of soil layers in the column - ! that are biogeochemically active - real(r8),allocatable :: zi_sisl(:) ! interface level below a "z" level (m) - ! this contains a zero index for surface. - real(r8),allocatable :: dz_sisl(:) ! layer thickness (m) - real(r8),allocatable :: z_sisl(:) ! layer depth (m) - - ! Decomposition Layer Structure - real(r8), allocatable :: dz_decomp_sisl(:) ! This should match dz_sisl(), unless - ! only one layer is chosen, in that - ! case, it has its own depth, which - ! has traditionally been 1 meter - - integer,allocatable :: decomp_id(:) ! The decomposition layer index that each - ! soil layer maps to. This will either - ! be equivalent (ie integer ascending) - ! Or, all will be 1. - - - ! Vegetation Dynamics - ! --------------------------------------------------------------------------------- - - ! The site level 24 hour vegetation temperature is used for various purposes during vegetation - ! dynamics. However, we are currently using the bare ground patch's value [K] - ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. - ! It is possible that the bare-ground value is where the average is being stored. - ! (RGK-01-2017) - real(r8) :: t_veg24_si - - ! Patch 24 hour vegetation temperature [K] - real(r8),allocatable :: t_veg24_pa(:) - - ! Fire Model - - ! Average precipitation over the last 24 hours [mm/s] - real(r8), allocatable :: precip24_pa(:) - - ! Average relative humidity over past 24 hours [-] - real(r8), allocatable :: relhumid24_pa(:) - - ! Patch 24-hour running mean of wind (m/s ?) - real(r8), allocatable :: wind24_pa(:) - - - ! Radiation variables for calculating sun/shade fractions - ! --------------------------------------------------------------------------------- - - ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] - real(r8), allocatable :: solad_parb(:,:) - - ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] - real(r8), allocatable :: solai_parb(:,:) - + ! Just use everything from FatesInterfaceTypesMod, this is + ! its sister code + use FatesInterfaceTypesMod - ! Photosynthesis variables - ! --------------------------------------------------------------------------------- - - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis at least once - integer, allocatable :: filter_photo_pa(:) - - ! atmospheric pressure (Pa) - real(r8) :: forc_pbot - - ! daylength scaling factor (0-1) - real(r8), allocatable :: dayl_factor_pa(:) - - ! saturation vapor pressure at t_veg (Pa) - real(r8), allocatable :: esat_tv_pa(:) - - ! vapor pressure of canopy air (Pa) - real(r8), allocatable :: eair_pa(:) - - ! Atmospheric O2 partial pressure (Pa) - real(r8), allocatable :: oair_pa(:) - - ! Atmospheric CO2 partial pressure (Pa) - real(r8), allocatable :: cair_pa(:) - - ! boundary layer resistance (s/m) - real(r8), allocatable :: rb_pa(:) - - ! vegetation temperature (Kelvin) - real(r8), allocatable :: t_veg_pa(:) - - ! air temperature at agcm reference height (kelvin) - real(r8), allocatable :: tgcm_pa(:) - - ! soil temperature (Kelvin) - real(r8), allocatable :: t_soisno_sl(:) - - ! Canopy Radiation Boundaries - ! --------------------------------------------------------------------------------- - - ! Filter for vegetation patches with a positive zenith angle (daylight) - logical, allocatable :: filter_vegzen_pa(:) - - ! Cosine of the zenith angle (0-1), by patch - ! Note RGK: It does not seem like the code would currently generate - ! different zenith angles for different patches (nor should it) - ! I am leaving it at this scale for simplicity. Patches should - ! have no spacially variable information - real(r8), allocatable :: coszen_pa(:) - - ! Abledo of the ground for direct radiation, by site broadband (0-1) - real(r8), allocatable :: albgr_dir_rb(:) - - ! Albedo of the ground for diffuse radiation, by site broadband (0-1) - real(r8), allocatable :: albgr_dif_rb(:) - - ! LitterFlux Boundaries - ! the index of the deepest model soil level where roots may be - ! due to permafrost or bedrock constraints - integer :: max_rooting_depth_index_col - - ! BGC Accounting - - real(r8) :: tot_het_resp ! total heterotrophic respiration (gC/m2/s) - real(r8) :: tot_somc ! total soil organic matter carbon (gc/m2) - real(r8) :: tot_litc ! total litter carbon tracked in the HLM (gc/m2) - - ! Canopy Structure - - real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) - real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) - - ! Hydrology variables for BTRAN - ! --------------------------------------------------------------------------------- - - ! Soil suction potential of layers in each site, negative, [mm] - real(r8), allocatable :: smp_sl(:) - - !soil salinity of layers in each site [ppt] - real(r8), allocatable :: salinity_sl(:) - - ! Effective porosity = porosity - vol_ic, of layers in each site [-] - real(r8), allocatable :: eff_porosity_sl(:) - - ! volumetric soil water at saturation (porosity) - real(r8), allocatable :: watsat_sl(:) - - ! Temperature of ground layers [K] - real(r8), allocatable :: tempk_sl(:) - - ! Liquid volume in ground layer (m3/m3) - real(r8), allocatable :: h2o_liqvol_sl(:) - - ! Site level filter for uptake response functions - logical :: filter_btran - - - ! ALL HYDRO DATA STRUCTURES SHOULD NOW BE ALLOCATED ON RHIZOSPHERE LEVELS - - ! Plant-Hydro - ! --------------------------------------------------------------------------------- - - real(r8),allocatable :: qflx_transp_pa(:) ! Transpiration flux as dictated by the HLM's - ! canopy solver. [mm H2O/s] [+ into root] - real(r8),allocatable :: swrad_net_pa(:) ! Net absorbed shortwave radiation (W/m2) - real(r8),allocatable :: lwrad_net_pa(:) ! Net absorbed longwave radiation (W/m2) - real(r8),allocatable :: watsat_sisl(:) ! volumetric soil water at saturation (porosity) - real(r8),allocatable :: watres_sisl(:) ! volumetric residual soil water - real(r8),allocatable :: sucsat_sisl(:) ! minimum soil suction (mm) - real(r8),allocatable :: bsw_sisl(:) ! Clapp and Hornberger "b" - real(r8),allocatable :: hksat_sisl(:) ! hydraulic conductivity at saturation (mm H2O /s) - real(r8),allocatable :: h2o_liq_sisl(:) ! Liquid water mass in each layer (kg/m2) - real(r8) :: smpmin_si ! restriction for min of soil potential (mm) - - end type bc_in_type - - - type, public :: bc_out_type - - ! Sunlit fraction of the canopy for this patch [0-1] - real(r8),allocatable :: fsun_pa(:) - - ! Sunlit canopy LAI - real(r8),allocatable :: laisun_pa(:) - - ! Shaded canopy LAI - real(r8),allocatable :: laisha_pa(:) - - ! Logical stating whether a ground layer can have water uptake by plants - ! The only condition right now is that liquid water exists - ! The name (suction) is used to indicate that soil suction should be calculated - logical, allocatable :: active_suction_sl(:) - - ! Effective fraction of roots in each soil layer - real(r8), allocatable :: rootr_pasl(:,:) - - ! Integrated (vertically) transpiration wetness factor (0 to 1) - ! (diagnostic, should not be used by HLM) - real(r8), allocatable :: btran_pa(:) - - ! Sunlit canopy resistance [s/m] - real(r8), allocatable :: rssun_pa(:) - - ! Shaded canopy resistance [s/m] - real(r8), allocatable :: rssha_pa(:) - - ! leaf photosynthesis (umol CO2 /m**2/ s) - ! (NOT CURRENTLY USED, PLACE-HOLDER) - !real(r8), allocatable :: psncanopy_pa(:) - - ! leaf maintenance respiration rate (umol CO2/m**2/s) - ! (NOT CURRENTLY USED, PLACE-HOLDER) - !real(r8), allocatable :: lmrcanopy_pa(:) - - ! Canopy Radiation Boundaries - ! --------------------------------------------------------------------------------- - - ! Surface albedo (direct) (HLMs use this for atm coupling and balance checks) - real(r8), allocatable :: albd_parb(:,:) - - ! Surface albedo (diffuse) (HLMs use this for atm coupling and balance checks) - real(r8), allocatable :: albi_parb(:,:) - - ! Flux absorbed by canopy per unit direct flux (HLMs use this for balance checks) - real(r8), allocatable :: fabd_parb(:,:) - - ! Flux absorbed by canopy per unit diffuse flux (HLMs use this for balance checks) - real(r8), allocatable :: fabi_parb(:,:) - - ! Down direct flux below canopy per unit direct flx (HLMs use this for balance checks) - real(r8), allocatable :: ftdd_parb(:,:) - - ! Down diffuse flux below canopy per unit direct flx (HLMs use this for balance checks) - real(r8), allocatable :: ftid_parb(:,:) - - ! Down diffuse flux below canopy per unit diffuse flx (HLMs use this for balance checks) - real(r8), allocatable :: ftii_parb(:,:) - - - ! Mass fluxes to BGC from fragmentation of litter into decomposing pools - - real(r8), allocatable :: litt_flux_cel_c_si(:) ! cellulose carbon litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lig_c_si(:) ! lignan carbon litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lab_c_si(:) ! labile carbon litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_cel_n_si(:) ! cellulose nitrogen litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lig_n_si(:) ! lignan nitrogen litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lab_n_si(:) ! labile nitrogen litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_cel_p_si(:) ! cellulose phosphorus litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lig_p_si(:) ! lignan phosphorus litter, fates->BGC g/m3/s - real(r8), allocatable :: litt_flux_lab_p_si(:) ! labile phosphorus litter, fates->BGC g/m3/s - - ! Canopy Structure - - real(r8), allocatable :: elai_pa(:) ! exposed leaf area index - real(r8), allocatable :: esai_pa(:) ! exposed stem area index - real(r8), allocatable :: tlai_pa(:) ! total leaf area index - real(r8), allocatable :: tsai_pa(:) ! total stem area index - real(r8), allocatable :: htop_pa(:) ! top of the canopy [m] - real(r8), allocatable :: hbot_pa(:) ! bottom of canopy? [m] - - real(r8), allocatable :: z0m_pa(:) ! roughness length [m] - real(r8), allocatable :: displa_pa(:) ! displacement height [m] - real(r8), allocatable :: dleaf_pa(:) ! leaf characteristic dimension/width/diameter [m] - - real(r8), allocatable :: canopy_fraction_pa(:) ! Area fraction of each patch in the site - ! Use most likely for weighting - ! This is currently the projected canopy - ! area of each patch [0-1] - - real(r8), allocatable :: frac_veg_nosno_alb_pa(:) ! This is not really a fraction - ! this is actually binary based on if any - ! vegetation in the patch is exposed. - ! [0,1] - - ! FATES Hydraulics - - - - real(r8) :: plant_stored_h2o_si ! stored water in LIVE+DEAD vegetation (kg/m2 H2O) - ! Assuming density of 1Mg/m3 ~= mm/m2 H2O - ! This must be set and transfered prior to clm_drv() - ! following the calls to ed_update_site() - ! ed_update_site() is called during both the restart - ! and coldstart process - - real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer - ! [mm H2O/s] [+ into root] - - real(r8),allocatable :: qflx_ro_sisl(:) ! Water flux runoff generated by - ! root to soil flux super-saturating the soils - ! This does seem unlikely, but we need accomodate - ! small fluxes for various reasons - ! [mm H2O/s] - - - end type bc_out_type - - - type, public :: fates_interface_type - - ! This is the root of the ED/FATES hierarchy of instantaneous state variables - ! ie the root of the linked lists. Each path list is currently associated with a - ! grid-cell, this is intended to be migrated to columns - - integer :: nsites - - type(ed_site_type), pointer :: sites(:) - - ! These are boundary conditions that the FATES models are required to be filled. - ! These values are filled by the driver or HLM. Once filled, these have an - ! intent(in) status. Each site has a derived type structure, which may include - ! a scalar for site level data, a patch vector, potentially cohort vectors (but - ! not yet atm) and other dimensions such as soil-depth or pft. These vectors - ! are initialized by maximums, and the allocations are static in time to avoid - ! having to allocate/de-allocate memory - - type(bc_in_type), allocatable :: bc_in(:) - - ! These are the boundary conditions that the FATES model returns to its HLM or - ! driver. It has the same allocation strategy and similar vector types. - - type(bc_out_type), allocatable :: bc_out(:) - - contains - - procedure, public :: zero_bcs - procedure, public :: set_bcs - - end type fates_interface_type - - ! Make public necessary subroutines and functions public :: FatesInterfaceInit public :: set_fates_ctrlparms @@ -633,13 +64,13 @@ module FatesInterfaceMod contains - ! ==================================================================================== + ! ==================================================================================== subroutine FatesInterfaceInit(log_unit,global_verbose) - + use FatesGlobals, only : FatesGlobalsInit - + implicit none - + integer, intent(in) :: log_unit logical, intent(in) :: global_verbose @@ -647,26 +78,26 @@ subroutine FatesInterfaceInit(log_unit,global_verbose) end subroutine FatesInterfaceInit - ! ==================================================================================== - - ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... - subroutine fates_clean(this) - - implicit none - - ! Input Arguments - class(fates_interface_type), intent(inout) :: this - - ! Incrementally walk through linked list and deallocate - + ! ==================================================================================== + + ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... + subroutine fates_clean(this) + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + + ! Incrementally walk through linked list and deallocate + + - ! Deallocate the site list -! deallocate (this%sites) + ! Deallocate the site list + ! deallocate (this%sites) - return - end subroutine fates_clean - + return + end subroutine fates_clean + ! ==================================================================================== @@ -796,6 +227,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in) return end subroutine allocate_bcin + + ! ==================================================================================== subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) @@ -881,123 +314,8 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) end subroutine allocate_bcout ! ==================================================================================== - - subroutine zero_bcs(this,s) - - implicit none - class(fates_interface_type), intent(inout) :: this - integer, intent(in) :: s - - ! Input boundaries - - this%bc_in(s)%t_veg24_si = 0.0_r8 - this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 - this%bc_in(s)%precip24_pa(:) = 0.0_r8 - this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 - this%bc_in(s)%wind24_pa(:) = 0.0_r8 - - this%bc_in(s)%solad_parb(:,:) = 0.0_r8 - this%bc_in(s)%solai_parb(:,:) = 0.0_r8 - this%bc_in(s)%smp_sl(:) = 0.0_r8 - this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 - this%bc_in(s)%watsat_sl(:) = 0.0_r8 - this%bc_in(s)%tempk_sl(:) = 0.0_r8 - this%bc_in(s)%h2o_liqvol_sl(:) = 0.0_r8 - this%bc_in(s)%filter_vegzen_pa(:) = .false. - this%bc_in(s)%coszen_pa(:) = 0.0_r8 - this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 - this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 - this%bc_in(s)%max_rooting_depth_index_col = 0 - this%bc_in(s)%tot_het_resp = 0.0_r8 - this%bc_in(s)%tot_somc = 0.0_r8 - this%bc_in(s)%tot_litc = 0.0_r8 - this%bc_in(s)%snow_depth_si = 0.0_r8 - this%bc_in(s)%frac_sno_eff_si = 0.0_r8 - - if(do_fates_salinity)then - this%bc_in(s)%salinity_sl(:) = 0.0_r8 - endif - - if (hlm_use_planthydro.eq.itrue) then - - this%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 - this%bc_in(s)%swrad_net_pa(:) = 0.0_r8 - this%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 - this%bc_in(s)%watsat_sisl(:) = 0.0_r8 - this%bc_in(s)%watres_sisl(:) = 0.0_r8 - this%bc_in(s)%sucsat_sisl(:) = 0.0_r8 - this%bc_in(s)%bsw_sisl(:) = 0.0_r8 - this%bc_in(s)%hksat_sisl(:) = 0.0_r8 - end if - - - ! Output boundaries - this%bc_out(s)%active_suction_sl(:) = .false. - this%bc_out(s)%fsun_pa(:) = 0.0_r8 - this%bc_out(s)%laisun_pa(:) = 0.0_r8 - this%bc_out(s)%laisha_pa(:) = 0.0_r8 - this%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 - this%bc_out(s)%btran_pa(:) = 0.0_r8 - - ! Fates -> BGC fragmentation mass fluxes - select case(hlm_parteh_mode) - case(prt_carbon_allom_hyp) - this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 - case(prt_cnp_flex_allom_hyp) - this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_cel_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 - case default - write(fates_log(), *) 'An unknown parteh hypothesis was passed' - write(fates_log(), *) 'while zeroing output boundary conditions' - write(fates_log(), *) 'hlm_parteh_mode: ',hlm_parteh_mode - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - - - this%bc_out(s)%rssun_pa(:) = 0.0_r8 - this%bc_out(s)%rssha_pa(:) = 0.0_r8 - - this%bc_out(s)%albd_parb(:,:) = 0.0_r8 - this%bc_out(s)%albi_parb(:,:) = 0.0_r8 - this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 - this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 - - this%bc_out(s)%elai_pa(:) = 0.0_r8 - this%bc_out(s)%esai_pa(:) = 0.0_r8 - this%bc_out(s)%tlai_pa(:) = 0.0_r8 - this%bc_out(s)%tsai_pa(:) = 0.0_r8 - this%bc_out(s)%htop_pa(:) = 0.0_r8 - this%bc_out(s)%hbot_pa(:) = 0.0_r8 - this%bc_out(s)%displa_pa(:) = 0.0_r8 - this%bc_out(s)%z0m_pa(:) = 0.0_r8 - this%bc_out(s)%dleaf_pa(:) = 0.0_r8 - - this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 - this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 - - if (hlm_use_planthydro.eq.itrue) then - this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 - this%bc_out(s)%qflx_ro_sisl(:) = 0.0_r8 - end if - this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 - - return - end subroutine zero_bcs - subroutine set_bcs(this,s) + subroutine set_bcs(bc_in) ! -------------------------------------------------------------------------------- ! @@ -1011,8 +329,7 @@ subroutine set_bcs(this,s) ! ! -------------------------------------------------------------------------------- implicit none - class(fates_interface_type), intent(inout) :: this - integer, intent(in) :: s + type(bc_in_type), intent(inout) :: bc_in ! Input boundaries ! Warning: these "z" type variables @@ -1020,12 +337,11 @@ subroutine set_bcs(this,s) ! so THIS ROUTINE SHOULD NOT BE CALLED AFTER ! INITIALIZATION if(do_fates_salinity)then - this%bc_in(s)%salinity_sl(:) = bgc_soil_salinity + bc_in%salinity_sl(:) = bgc_soil_salinity endif - + end subroutine set_bcs - ! =================================================================================== subroutine set_fates_global_elements(use_fates) @@ -1046,10 +362,7 @@ subroutine set_fates_global_elements(use_fates) ! ! -------------------------------------------------------------------------------- - use EDParamsMod, only : ED_val_history_sizeclass_bin_edges, ED_val_history_ageclass_bin_edges - use EDParamsMod, only : ED_val_history_height_bin_edges - use EDParamsMod, only : ED_val_history_coageclass_bin_edges - use CLMFatesParamInterfaceMod , only : FatesReadParameters + implicit none logical,intent(in) :: use_fates ! Is fates turned on? @@ -1073,14 +386,14 @@ subroutine set_fates_global_elements(use_fates) write(fates_log(), *) 'it was found that the lower bound was neither 0 or 1?' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(numpft>maxpft) then write(fates_log(), *) 'The number of PFTs dictated by the FATES parameter file' write(fates_log(), *) 'is larger than the maximum allowed. Increase the FATES parameter constant' write(fates_log(), *) 'FatesInterfaceMod.F90:maxpft accordingly' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Identify the number of leaf age-classes if( (lbound(EDPftvarcon_inst%leaf_long(:,:),dim=2) .eq. 0) .or. & @@ -1152,6 +465,21 @@ subroutine set_fates_global_elements(use_fates) end if end do + ! Initialize Hydro globals + ! (like water retention functions) + ! this needs to know the number of PFTs, which is + ! determined in that call + call InitHydroGlobals(numpft) + + ! Initialize the Plant Allocation and Reactive Transport + ! global functions and mapping tables + ! Also associate the elements defined in PARTEH with a list in FATES + ! "element_list" is useful because it allows the fates side of the code + ! to loop through elements, and call the correct PARTEH interfaces + ! automatically. + call InitPARTEHGlobals() + + ! Set Various Mapping Arrays used in history output as well ! These will not be used if use_ed or use_fates is false call fates_history_maps() @@ -1172,7 +500,59 @@ subroutine set_fates_global_elements(use_fates) end subroutine set_fates_global_elements - !============================================================================================== + ! ====================================================================== + + subroutine InitPARTEHGlobals() + + ! Initialize the Plant Allocation and Reactive Transport + ! global functions and mapping tables + ! Also associate the elements defined in PARTEH with a list in FATES + ! "element_list" is useful because it allows the fates side of the code + ! to loop through elements, and call the correct PARTEH interfaces + ! automatically. + + select case(hlm_parteh_mode) + case(prt_carbon_allom_hyp) + + num_elements = 1 + allocate(element_list(num_elements)) + element_list(1) = carbon12_element + element_pos(:) = 0 + element_pos(carbon12_element) = 1 + + call InitPRTGlobalAllometricCarbon() + + case(prt_cnp_flex_allom_hyp) + + num_elements = 3 + allocate(element_list(num_elements)) + element_list(1) = carbon12_element + element_list(2) = nitrogen_element + element_list(3) = phosphorus_element + element_pos(:) = 0 + element_pos(carbon12_element) = 1 + element_pos(nitrogen_element) = 2 + element_pos(phosphorus_element) = 3 + + !call InitPRTGlobalAllometricCNP() + write(fates_log(),*) 'You specified the allometric CNP mode' + write(fates_log(),*) 'with relaxed target stoichiometry.' + write(fates_log(),*) 'I.e., namelist parametre fates_parteh_mode = 2' + write(fates_log(),*) 'This mode is not available yet. Please set it to 1.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case DEFAULT + write(fates_log(),*) 'You specified an unknown PRT module' + write(fates_log(),*) 'Check your setting for fates_parteh_mode' + write(fates_log(),*) 'in the CLM namelist. The only valid value now is 1' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + end subroutine InitPARTEHGlobals + + !============================================================================================== subroutine fates_history_maps @@ -1841,7 +1221,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) return end subroutine set_fates_ctrlparms - + ! ==================================================================================== subroutine FatesReportParameters(masterproc) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 new file mode 100644 index 0000000000..a7bd57ea70 --- /dev/null +++ b/main/FatesInterfaceTypesMod.F90 @@ -0,0 +1,698 @@ +module FatesInterfaceTypesMod + implicit none + + private ! By default everything is private + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by the Host Land Model + ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. + ! ------------------------------------------------------------------------------------- + + + integer, public, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + integer, public, protected :: hlm_ivis ! The HLMs assumption of the array index associated with the + ! visible portion of the spectrum in short-wave radiation arrays + + integer, public, protected :: hlm_inir ! The HLMs assumption of the array index associated with the + ! NIR portion of the spectrum in short-wave radiation arrays + + + integer, public, protected :: hlm_numlevgrnd ! Number of ground layers + ! NOTE! SOIL LAYERS ARE NOT A GLOBAL, THEY + ! ARE VARIABLE BY SITE + + integer, public, protected :: hlm_is_restart ! Is the HLM signalling that this is a restart + ! type simulation? + ! 1=TRUE, 0=FALSE + + character(len=16), public, protected :: hlm_name ! This character string passed by the HLM + ! is used during the processing of IO data, + ! so that FATES knows which IO variables it + ! should prepare. For instance + ! ATS, ALM and CLM will only want variables + ! specficially packaged for them. + ! This string sets which filter is enacted. + + + real(r8), public, protected :: hlm_hio_ignore_val ! This value can be flushed to history + ! diagnostics, such that the + ! HLM will interpret that the value should not + ! be included in the average. + + integer, public, protected :: hlm_masterproc ! Is this the master processor, typically useful + ! for knowing if the current machine should be + ! printing out messages to the logs or terminals + ! 1 = TRUE (is master) 0 = FALSE (is not master) + + integer, public, protected :: hlm_ipedof ! The HLM pedotransfer index + ! this is only used by the plant hydraulics + ! submodule to check and/or enable consistency + ! between the pedotransfer functions of the HLM + ! and how it moves and stores water in its + ! rhizosphere shells + + integer, public, protected :: hlm_max_patch_per_site ! The HLM needs to exchange some patch + ! level quantities with FATES + ! FATES does not dictate those allocations + ! since it happens pretty early in + ! the model initialization sequence. + ! So we want to at least query it, + ! compare it to our maxpatchpersite, + ! and gracefully halt if we are over-allocating + + integer, public, protected :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive + ! Transport (exensible) Hypothesis (PARTEH) to use + + + integer, public, protected :: hlm_use_vertsoilc ! This flag signals whether or not the + ! host model is using vertically discretized + ! soil carbon + ! 1 = TRUE, 0 = FALSE + + integer, public, protected :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE + ! 1 = TRUE, 0 = FALSE + + + integer, public, protected :: hlm_use_logging ! This flag signals whether or not to use + ! the logging module + + integer, public, protected :: hlm_use_planthydro ! This flag signals whether or not to use + ! plant hydraulics (bchristo/xu methods) + ! 1 = TRUE, 0 = FALSE + ! THIS IS CURRENTLY NOT SUPPORTED + + integer, public, protected :: hlm_use_cohort_age_tracking ! This flag signals whether or not to use + ! cohort age tracking. 1 = TRUE, 0 = FALSE + + integer, public, protected :: hlm_use_ed_st3 ! This flag signals whether or not to use + ! (ST)atic (ST)and (ST)ructure mode (ST3) + ! Essentially, this gives us the ability + ! to turn off "dynamics", ie growth, disturbance + ! recruitment and mortality. + ! (EXPERIMENTAL!!!!! - RGK 07-2017) + ! 1 = TRUE, 0 = FALSE + ! default should be FALSE (dynamics on) + ! cannot be true with prescribed_phys + + integer, public, protected :: hlm_use_ed_prescribed_phys ! This flag signals whether or not to use + ! prescribed physiology, somewhat the opposite + ! to ST3, in this case can turn off + ! fast processes like photosynthesis and respiration + ! and prescribe NPP + ! (NOT CURRENTLY IMPLEMENTED - PLACEHOLDER) + ! 1 = TRUE, 0 = FALSE + ! default should be FALSE (biophysics on) + ! cannot be true with st3 mode + + integer, public, protected :: hlm_use_inventory_init ! Initialize this simulation from + ! an inventory file. If this is toggled on + ! an inventory control file must be specified + ! as well. + ! 1 = TRUE, 0 = FALSE + + character(len=256), public, protected :: hlm_inventory_ctrl_file ! This is the full path to the + ! inventory control file that + ! specifieds the availabel inventory datasets + ! there locations and their formats + ! This need only be defined when + ! hlm_use_inventory_init = 1 + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by FATES and known to be required knowledge + ! needed by the HLMs + ! ------------------------------------------------------------------------------------- + + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + integer, public, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + ! used to set the size of the largest arrays necessary + ! in things like restart files (probably hosted by the + ! HLM). The size of these arrays are not a parameter + ! because it is simply the maximum of several different + ! dimensions. It is possible that this would be the + ! maximum number of cohorts per patch, but + ! but it could be other things. + + integer, public, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + ! ------------------------------------------------------------------------------------- + ! These vectors are used for history output mapping + ! CLM/ALM have limited support for multi-dimensional history output arrays. + ! FATES structure and composition is multi-dimensional, so we end up "multi-plexing" + ! multiple dimensions into one dimension. These new dimensions need definitions, + ! mapping to component dimensions, and definitions for those component dimensions as + ! well. + ! ------------------------------------------------------------------------------------- + + real(r8), public, allocatable :: fates_hdim_levcoage(:) ! cohort age class lower bound dimension + integer , public, allocatable :: fates_hdim_pfmap_levcapf(:) ! map of pfts into cohort age class x pft dimension + integer , public, allocatable :: fates_hdim_camap_levcapf(:) ! map of cohort age class into cohort age x pft dimension + + + real(r8), public, allocatable :: fates_hdim_levsclass(:) ! plant size class lower bound dimension + integer , public, allocatable :: fates_hdim_pfmap_levscpf(:) ! map of pfts into size-class x pft dimension + integer , public, allocatable :: fates_hdim_scmap_levscpf(:) ! map of size-class into size-class x pft dimension + real(r8), public, allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension + real(r8), public, allocatable :: fates_hdim_levheight(:) ! height lower bound dimension + integer , public, allocatable :: fates_hdim_levpft(:) ! plant pft dimension + integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel class dimension + integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension + integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension + integer , public, allocatable :: fates_hdim_levelem(:) ! element dimension + integer , public, allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dim + integer , public, allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the can-layer x leaf-layer dimension + integer , public, allocatable :: fates_hdim_canmap_levcnlfpf(:) ! can-layer map into the can-layer x pft x leaf-layer dim + integer , public, allocatable :: fates_hdim_lfmap_levcnlfpf(:) ! leaf-layer map into the can-layer x pft x leaf-layer dim + integer , public, allocatable :: fates_hdim_pftmap_levcnlfpf(:) ! pft map into the canopy-layer x pft x leaf-layer dim + integer , public, allocatable :: fates_hdim_scmap_levscag(:) ! map of size-class into size-class x patch age dimension + integer , public, allocatable :: fates_hdim_agmap_levscag(:) ! map of patch-age into size-class x patch age dimension + integer , public, allocatable :: fates_hdim_scmap_levscagpft(:) ! map of size-class into size-class x patch age x pft dimension + integer , public, allocatable :: fates_hdim_agmap_levscagpft(:) ! map of patch-age into size-class x patch age x pft dimension + integer , public, allocatable :: fates_hdim_pftmap_levscagpft(:) ! map of pft into size-class x patch age x pft dimension + integer , public, allocatable :: fates_hdim_agmap_levagepft(:) ! map of patch-age into patch age x pft dimension + integer , public, allocatable :: fates_hdim_pftmap_levagepft(:) ! map of pft into patch age x pft dimension + + integer , public, allocatable :: fates_hdim_elmap_levelpft(:) ! map of elements in the element x pft dimension + integer , public, allocatable :: fates_hdim_elmap_levelcwd(:) ! map of elements in the element x cwd dimension + integer , public, allocatable :: fates_hdim_elmap_levelage(:) ! map of elements in the element x age dimension + integer , public, allocatable :: fates_hdim_pftmap_levelpft(:) ! map of pfts in the element x pft dimension + integer , public, allocatable :: fates_hdim_cwdmap_levelcwd(:) ! map of cwds in the element x cwd dimension + integer , public, allocatable :: fates_hdim_agemap_levelage(:) ! map of ages in the element x age dimension + + ! ------------------------------------------------------------------------------------ + ! DYNAMIC BOUNDARY CONDITIONS + ! ------------------------------------------------------------------------------------ + + + ! ------------------------------------------------------------------------------------- + ! Scalar Timing Variables + ! It is assumed that all of the sites on a given machine will be synchronous. + ! It is also assumed that the HLM will control time. + ! ------------------------------------------------------------------------------------- + integer, public, protected :: hlm_current_year ! Current year + integer, public, protected :: hlm_current_month ! month of year + integer, public, protected :: hlm_current_day ! day of month + integer, public, protected :: hlm_current_tod ! time of day (seconds past 0Z) + integer, public, protected :: hlm_current_date ! time of day (seconds past 0Z) + integer, public, protected :: hlm_reference_date ! YYYYMMDD + real(r8), public, protected :: hlm_model_day ! elapsed days between current date and ref + integer, public, protected :: hlm_day_of_year ! The integer day of the year + integer, public, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may + ! include a leap + real(r8), public, protected :: hlm_freq_day ! fraction of year for daily time-step + ! (1/days_per_year_, this is a frequency + + + ! ------------------------------------------------------------------------------------- + ! + ! Constant parameters that are dictated by the fates parameter file + ! + ! ------------------------------------------------------------------------------------- + + integer, public, protected :: numpft ! The total number of PFTs defined in the simulation + integer, public, protected :: nlevsclass ! The total number of cohort size class bins output to history + integer, public, protected :: nlevage ! The total number of patch age bins output to history + integer, public, protected :: nlevheight ! The total number of height bins output to history + integer, public, protected :: nlevcoage ! The total number of cohort age bins output to history + integer, public, protected :: nleafage ! The total number of leaf age classes + + ! ------------------------------------------------------------------------------------- + ! Structured Boundary Conditions (SITE/PATCH SCALE) + ! For floating point arrays, it is sometimes the convention to define the arrays as + ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle + ! differences. POINTER arrays can point to scalar values, discontinuous array slices + ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel + ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point + ! to contiguous memory spaces and do not alias other variables, the case here. + ! Naming conventions: _si means site dimensions (scalar in that case) + ! _pa means patch dimensions + ! _rb means radiation band + ! _sl means soil layer + ! _sisl means site x soil layer + ! ------------------------------------------------------------------------------------ + + type, public :: bc_in_type + + ! The actual number of FATES' ED patches + integer :: npatches + + + ! Soil layer structure + + integer :: nlevsoil ! the number of soil layers in this column + integer :: nlevdecomp ! the number of soil layers in the column + ! that are biogeochemically active + real(r8),allocatable :: zi_sisl(:) ! interface level below a "z" level (m) + ! this contains a zero index for surface. + real(r8),allocatable :: dz_sisl(:) ! layer thickness (m) + real(r8),allocatable :: z_sisl(:) ! layer depth (m) + + ! Decomposition Layer Structure + real(r8), allocatable :: dz_decomp_sisl(:) ! This should match dz_sisl(), unless + ! only one layer is chosen, in that + ! case, it has its own depth, which + ! has traditionally been 1 meter + + integer,allocatable :: decomp_id(:) ! The decomposition layer index that each + ! soil layer maps to. This will either + ! be equivalent (ie integer ascending) + ! Or, all will be 1. + + + ! Vegetation Dynamics + ! --------------------------------------------------------------------------------- + + ! The site level 24 hour vegetation temperature is used for various purposes during vegetation + ! dynamics. However, we are currently using the bare ground patch's value [K] + ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. + ! It is possible that the bare-ground value is where the average is being stored. + ! (RGK-01-2017) + real(r8) :: t_veg24_si + + ! Patch 24 hour vegetation temperature [K] + real(r8),allocatable :: t_veg24_pa(:) + + ! Fire Model + + ! Average precipitation over the last 24 hours [mm/s] + real(r8), allocatable :: precip24_pa(:) + + ! Average relative humidity over past 24 hours [-] + real(r8), allocatable :: relhumid24_pa(:) + + ! Patch 24-hour running mean of wind (m/s ?) + real(r8), allocatable :: wind24_pa(:) + + + ! Radiation variables for calculating sun/shade fractions + ! --------------------------------------------------------------------------------- + + ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solad_parb(:,:) + + ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solai_parb(:,:) + + + + ! Photosynthesis variables + ! --------------------------------------------------------------------------------- + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + integer, allocatable :: filter_photo_pa(:) + + ! atmospheric pressure (Pa) + real(r8) :: forc_pbot + + ! daylength scaling factor (0-1) + real(r8), allocatable :: dayl_factor_pa(:) + + ! saturation vapor pressure at t_veg (Pa) + real(r8), allocatable :: esat_tv_pa(:) + + ! vapor pressure of canopy air (Pa) + real(r8), allocatable :: eair_pa(:) + + ! Atmospheric O2 partial pressure (Pa) + real(r8), allocatable :: oair_pa(:) + + ! Atmospheric CO2 partial pressure (Pa) + real(r8), allocatable :: cair_pa(:) + + ! boundary layer resistance (s/m) + real(r8), allocatable :: rb_pa(:) + + ! vegetation temperature (Kelvin) + real(r8), allocatable :: t_veg_pa(:) + + ! air temperature at agcm reference height (kelvin) + real(r8), allocatable :: tgcm_pa(:) + + ! soil temperature (Kelvin) + real(r8), allocatable :: t_soisno_sl(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Filter for vegetation patches with a positive zenith angle (daylight) + logical, allocatable :: filter_vegzen_pa(:) + + ! Cosine of the zenith angle (0-1), by patch + ! Note RGK: It does not seem like the code would currently generate + ! different zenith angles for different patches (nor should it) + ! I am leaving it at this scale for simplicity. Patches should + ! have no spacially variable information + real(r8), allocatable :: coszen_pa(:) + + ! Abledo of the ground for direct radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dir_rb(:) + + ! Albedo of the ground for diffuse radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dif_rb(:) + + ! LitterFlux Boundaries + ! the index of the deepest model soil level where roots may be + ! due to permafrost or bedrock constraints + integer :: max_rooting_depth_index_col + + ! BGC Accounting + + real(r8) :: tot_het_resp ! total heterotrophic respiration (gC/m2/s) + real(r8) :: tot_somc ! total soil organic matter carbon (gc/m2) + real(r8) :: tot_litc ! total litter carbon tracked in the HLM (gc/m2) + + ! Canopy Structure + + real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) + real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) + + ! Hydrology variables for BTRAN + ! --------------------------------------------------------------------------------- + + ! Soil suction potential of layers in each site, negative, [mm] + real(r8), allocatable :: smp_sl(:) + + !soil salinity of layers in each site [ppt] + real(r8), allocatable :: salinity_sl(:) + + ! Effective porosity = porosity - vol_ic, of layers in each site [-] + real(r8), allocatable :: eff_porosity_sl(:) + + ! volumetric soil water at saturation (porosity) + real(r8), allocatable :: watsat_sl(:) + + ! Temperature of ground layers [K] + real(r8), allocatable :: tempk_sl(:) + + ! Liquid volume in ground layer (m3/m3) + real(r8), allocatable :: h2o_liqvol_sl(:) + + ! Site level filter for uptake response functions + logical :: filter_btran + + + ! ALL HYDRO DATA STRUCTURES SHOULD NOW BE ALLOCATED ON RHIZOSPHERE LEVELS + + ! Plant-Hydro + ! --------------------------------------------------------------------------------- + + real(r8),allocatable :: qflx_transp_pa(:) ! Transpiration flux as dictated by the HLM's + ! canopy solver. [mm H2O/s] [+ into root] + real(r8),allocatable :: swrad_net_pa(:) ! Net absorbed shortwave radiation (W/m2) + real(r8),allocatable :: lwrad_net_pa(:) ! Net absorbed longwave radiation (W/m2) + real(r8),allocatable :: watsat_sisl(:) ! volumetric soil water at saturation (porosity) + real(r8),allocatable :: watres_sisl(:) ! volumetric residual soil water + real(r8),allocatable :: sucsat_sisl(:) ! minimum soil suction (mm) + real(r8),allocatable :: bsw_sisl(:) ! Clapp and Hornberger "b" + real(r8),allocatable :: hksat_sisl(:) ! hydraulic conductivity at saturation (mm H2O /s) + real(r8),allocatable :: h2o_liq_sisl(:) ! Liquid water mass in each layer (kg/m2) + real(r8) :: smpmin_si ! restriction for min of soil potential (mm) + + end type bc_in_type + + + type, public :: bc_out_type + + ! Sunlit fraction of the canopy for this patch [0-1] + real(r8),allocatable :: fsun_pa(:) + + ! Sunlit canopy LAI + real(r8),allocatable :: laisun_pa(:) + + ! Shaded canopy LAI + real(r8),allocatable :: laisha_pa(:) + + ! Logical stating whether a ground layer can have water uptake by plants + ! The only condition right now is that liquid water exists + ! The name (suction) is used to indicate that soil suction should be calculated + logical, allocatable :: active_suction_sl(:) + + ! Effective fraction of roots in each soil layer + real(r8), allocatable :: rootr_pasl(:,:) + + ! Integrated (vertically) transpiration wetness factor (0 to 1) + ! (diagnostic, should not be used by HLM) + real(r8), allocatable :: btran_pa(:) + + ! Sunlit canopy resistance [s/m] + real(r8), allocatable :: rssun_pa(:) + + ! Shaded canopy resistance [s/m] + real(r8), allocatable :: rssha_pa(:) + + ! leaf photosynthesis (umol CO2 /m**2/ s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: psncanopy_pa(:) + + ! leaf maintenance respiration rate (umol CO2/m**2/s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: lmrcanopy_pa(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Surface albedo (direct) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albd_parb(:,:) + + ! Surface albedo (diffuse) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albi_parb(:,:) + + ! Flux absorbed by canopy per unit direct flux (HLMs use this for balance checks) + real(r8), allocatable :: fabd_parb(:,:) + + ! Flux absorbed by canopy per unit diffuse flux (HLMs use this for balance checks) + real(r8), allocatable :: fabi_parb(:,:) + + ! Down direct flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftdd_parb(:,:) + + ! Down diffuse flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftid_parb(:,:) + + ! Down diffuse flux below canopy per unit diffuse flx (HLMs use this for balance checks) + real(r8), allocatable :: ftii_parb(:,:) + + + ! Mass fluxes to BGC from fragmentation of litter into decomposing pools + + real(r8), allocatable :: litt_flux_cel_c_si(:) ! cellulose carbon litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lig_c_si(:) ! lignan carbon litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lab_c_si(:) ! labile carbon litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_cel_n_si(:) ! cellulose nitrogen litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lig_n_si(:) ! lignan nitrogen litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lab_n_si(:) ! labile nitrogen litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_cel_p_si(:) ! cellulose phosphorus litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lig_p_si(:) ! lignan phosphorus litter, fates->BGC g/m3/s + real(r8), allocatable :: litt_flux_lab_p_si(:) ! labile phosphorus litter, fates->BGC g/m3/s + + ! Canopy Structure + + real(r8), allocatable :: elai_pa(:) ! exposed leaf area index + real(r8), allocatable :: esai_pa(:) ! exposed stem area index + real(r8), allocatable :: tlai_pa(:) ! total leaf area index + real(r8), allocatable :: tsai_pa(:) ! total stem area index + real(r8), allocatable :: htop_pa(:) ! top of the canopy [m] + real(r8), allocatable :: hbot_pa(:) ! bottom of canopy? [m] + + real(r8), allocatable :: z0m_pa(:) ! roughness length [m] + real(r8), allocatable :: displa_pa(:) ! displacement height [m] + real(r8), allocatable :: dleaf_pa(:) ! leaf characteristic dimension/width/diameter [m] + + real(r8), allocatable :: canopy_fraction_pa(:) ! Area fraction of each patch in the site + ! Use most likely for weighting + ! This is currently the projected canopy + ! area of each patch [0-1] + + real(r8), allocatable :: frac_veg_nosno_alb_pa(:) ! This is not really a fraction + ! this is actually binary based on if any + ! vegetation in the patch is exposed. + ! [0,1] + + ! FATES Hydraulics + + + + real(r8) :: plant_stored_h2o_si ! stored water in LIVE+DEAD vegetation (kg/m2 H2O) + ! Assuming density of 1Mg/m3 ~= mm/m2 H2O + ! This must be set and transfered prior to clm_drv() + ! following the calls to ed_update_site() + ! ed_update_site() is called during both the restart + ! and coldstart process + + real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer + ! [mm H2O/s] [+ into root] + + real(r8),allocatable :: qflx_ro_sisl(:) ! Water flux runoff generated by + ! root to soil flux super-saturating the soils + ! This does seem unlikely, but we need accomodate + ! small fluxes for various reasons + ! [mm H2O/s] + + + end type bc_out_type + + + type, public :: fates_interface_type + + ! This is the root of the ED/FATES hierarchy of instantaneous state variables + ! ie the root of the linked lists. Each path list is currently associated with a + ! grid-cell, this is intended to be migrated to columns + + integer :: nsites + + type(ed_site_type), pointer :: sites(:) + + ! These are boundary conditions that the FATES models are required to be filled. + ! These values are filled by the driver or HLM. Once filled, these have an + ! intent(in) status. Each site has a derived type structure, which may include + ! a scalar for site level data, a patch vector, potentially cohort vectors (but + ! not yet atm) and other dimensions such as soil-depth or pft. These vectors + ! are initialized by maximums, and the allocations are static in time to avoid + ! having to allocate/de-allocate memory + + type(bc_in_type), allocatable :: bc_in(:) + + ! These are the boundary conditions that the FATES model returns to its HLM or + ! driver. It has the same allocation strategy and similar vector types. + + type(bc_out_type), allocatable :: bc_out(:) + + contains + + procedure, public :: zero_bcs + + end type fates_interface_type + + + ! ==================================================================================== + + subroutine zero_bcs(this,s) + + implicit none + class(fates_interface_type), intent(inout) :: this + integer, intent(in) :: s + + ! Input boundaries + + this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + this%bc_in(s)%precip24_pa(:) = 0.0_r8 + this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + this%bc_in(s)%wind24_pa(:) = 0.0_r8 + + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 + this%bc_in(s)%solai_parb(:,:) = 0.0_r8 + this%bc_in(s)%smp_sl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 + this%bc_in(s)%watsat_sl(:) = 0.0_r8 + this%bc_in(s)%tempk_sl(:) = 0.0_r8 + this%bc_in(s)%h2o_liqvol_sl(:) = 0.0_r8 + this%bc_in(s)%filter_vegzen_pa(:) = .false. + this%bc_in(s)%coszen_pa(:) = 0.0_r8 + this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 + this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 + this%bc_in(s)%max_rooting_depth_index_col = 0 + this%bc_in(s)%tot_het_resp = 0.0_r8 + this%bc_in(s)%tot_somc = 0.0_r8 + this%bc_in(s)%tot_litc = 0.0_r8 + this%bc_in(s)%snow_depth_si = 0.0_r8 + this%bc_in(s)%frac_sno_eff_si = 0.0_r8 + + if(do_fates_salinity)then + this%bc_in(s)%salinity_sl(:) = 0.0_r8 + endif + + if (hlm_use_planthydro.eq.itrue) then + + this%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 + this%bc_in(s)%swrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%watsat_sisl(:) = 0.0_r8 + this%bc_in(s)%watres_sisl(:) = 0.0_r8 + this%bc_in(s)%sucsat_sisl(:) = 0.0_r8 + this%bc_in(s)%bsw_sisl(:) = 0.0_r8 + this%bc_in(s)%hksat_sisl(:) = 0.0_r8 + end if + + + ! Output boundaries + this%bc_out(s)%active_suction_sl(:) = .false. + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%laisun_pa(:) = 0.0_r8 + this%bc_out(s)%laisha_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 + + ! Fates -> BGC fragmentation mass fluxes + select case(hlm_parteh_mode) + case(prt_carbon_allom_hyp) + this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 + case(prt_cnp_flex_allom_hyp) + this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 + this%bc_out(s)%litt_flux_cel_n_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lig_n_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lab_n_si(:) = 0._r8 + this%bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 + this%bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 + case default + write(fates_log(), *) 'An unknown parteh hypothesis was passed' + write(fates_log(), *) 'while zeroing output boundary conditions' + write(fates_log(), *) 'hlm_parteh_mode: ',hlm_parteh_mode + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + + + this%bc_out(s)%rssun_pa(:) = 0.0_r8 + this%bc_out(s)%rssha_pa(:) = 0.0_r8 + + this%bc_out(s)%albd_parb(:,:) = 0.0_r8 + this%bc_out(s)%albi_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + + this%bc_out(s)%elai_pa(:) = 0.0_r8 + this%bc_out(s)%esai_pa(:) = 0.0_r8 + this%bc_out(s)%tlai_pa(:) = 0.0_r8 + this%bc_out(s)%tsai_pa(:) = 0.0_r8 + this%bc_out(s)%htop_pa(:) = 0.0_r8 + this%bc_out(s)%hbot_pa(:) = 0.0_r8 + this%bc_out(s)%displa_pa(:) = 0.0_r8 + this%bc_out(s)%z0m_pa(:) = 0.0_r8 + this%bc_out(s)%dleaf_pa(:) = 0.0_r8 + + this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 + this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 + + if (hlm_use_planthydro.eq.itrue) then + this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 + this%bc_out(s)%qflx_ro_sisl(:) = 0.0_r8 + end if + this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 + + return + end subroutine zero_bcs + + +end module FatesInterfaceTypesMod diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 830ee7d099..4df7c25e14 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -28,9 +28,9 @@ module FatesInventoryInitMod use FatesConstantsMod, only : itrue use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log - use FatesInterfaceMod, only : bc_in_type - use FatesInterfaceMod, only : hlm_inventory_ctrl_file - use FatesInterfaceMod, only : nleafage + use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : hlm_inventory_ctrl_file + use FatesInterfaceTypesMod, only : nleafage use FatesLitterMod , only : litter_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type @@ -45,7 +45,7 @@ module FatesInventoryInitMod use EDTypesMod , only : phen_dstat_timeoff use EDTypesMod , only : phen_dstat_moistoff use EDPftvarcon , only : EDPftvarcon_inst - use FatesInterfaceMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_parteh_mode use EDCohortDynamicsMod, only : InitPRTObject use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp @@ -862,7 +862,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & use FatesAllometryMod , only : bstore_allom use EDCohortDynamicsMod , only : create_cohort - use FatesInterfaceMod , only : numpft + use FatesInterfaceTypesMod , only : numpft ! Arguments type(ed_site_type),intent(inout), target :: csite ! current site diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 index 36e528f939..66445c1906 100644 --- a/main/FatesParameterDerivedMod.F90 +++ b/main/FatesParameterDerivedMod.F90 @@ -12,7 +12,7 @@ module FatesParameterDerivedMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : umolC_to_kgC use FatesConstantsMod, only : g_per_kg - use FatesInterfaceMod, only : nleafage + use FatesInterfaceTypesMod, only : nleafage implicit none private diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 2929da121a..dbb790d2ca 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -14,11 +14,11 @@ module FatesRestartInterfaceMod use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type - use FatesInterfaceMod, only : nlevcoage - use FatesInterfaceMod, only : bc_in_type - use FatesInterfaceMod, only : bc_out_type - use FatesInterfaceMod, only : hlm_use_planthydro - use FatesInterfaceMod, only : fates_maxElementsPerSite + use FatesInterfaceTypesMod, only : nlevcoage + use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_out_type + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : fates_maxElementsPerSite use EDCohortDynamicsMod, only : UpdateCohortBioPhysRates use FatesHydraulicsMemMod, only : nshell use FatesHydraulicsMemMod, only : n_hypool_ag @@ -31,7 +31,7 @@ module FatesRestartInterfaceMod use EDCohortDynamicsMod, only : InitPRTObject use EDCohortDynamicsMod, only : InitPRTBoundaryConditions use FatesPlantHydraulicsMod, only : InitHydrCohort - use FatesInterfaceMod, only : nlevsclass + use FatesInterfaceTypesMod, only : nlevsclass use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy @@ -1353,7 +1353,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & hlms,initialize,ivar,index) use FatesUtilsMod, only : check_hlm_list - use FatesInterfaceMod, only : hlm_name + use FatesInterfaceTypesMod, only : hlm_name ! arguments class(fates_restart_interface_type) :: this @@ -1404,8 +1404,8 @@ end subroutine set_restart_var subroutine set_restart_vectors(this,nc,nsites,sites) - use FatesInterfaceMod, only : fates_maxElementsPerPatch - use FatesInterfaceMod, only : numpft + use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch + use FatesInterfaceTypesMod, only : numpft use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type @@ -1955,7 +1955,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb - use FatesInterfaceMod, only : fates_maxElementsPerPatch + use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : maxpft use EDTypesMod, only : area @@ -2147,8 +2147,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb - use FatesInterfaceMod, only : numpft - use FatesInterfaceMod, only : fates_maxElementsPerPatch + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index @@ -2679,7 +2679,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) use EDTypesMod, only : ed_site_type use EDTypesMod, only : ed_patch_type use EDSurfaceRadiationMod, only : PatchNormanRadiation - use FatesInterfaceMod, only : hlm_numSWb + use FatesInterfaceTypesMod, only : hlm_numSWb ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this diff --git a/main/FatesSizeAgeTypeIndicesMod.F90 b/main/FatesSizeAgeTypeIndicesMod.F90 index 5683cc5302..2205fdc619 100644 --- a/main/FatesSizeAgeTypeIndicesMod.F90 +++ b/main/FatesSizeAgeTypeIndicesMod.F90 @@ -1,10 +1,10 @@ module FatesSizeAgeTypeIndicesMod use FatesConstantsMod, only : r8 => fates_r8 - use FatesInterfaceMod, only : nlevsclass - use FatesInterfaceMod, only : nlevage - use FatesInterfaceMod, only : nlevheight - use FatesInterfaceMod, only : nlevcoage + use FatesInterfaceTypesMod, only : nlevsclass + use FatesInterfaceTypesMod, only : nlevage + use FatesInterfaceTypesMod, only : nlevheight + use FatesInterfaceTypesMod, only : nlevcoage use EDParamsMod, only : ED_val_history_sizeclass_bin_edges use EDParamsMod, only : ED_val_history_ageclass_bin_edges use EDParamsMod, only : ED_val_history_height_bin_edges From 15c5b8ed0b16581277b59f3727bf5547000bd0d4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 7 May 2020 16:08:46 -0700 Subject: [PATCH 099/114] Interface refactors, includes fixing the age based cohort cap, reshuffling call to FatesGlobals() to be earlier so we have error messages working for initialization sequence --- biogeochem/EDCohortDynamicsMod.F90 | 8 +- biogeophys/FatesPlantHydraulicsMod.F90 | 210 +++++++++++++++++++++-- main/EDInitMod.F90 | 1 - main/EDTypesMod.F90 | 6 +- main/FatesHydraulicsMemMod.F90 | 177 ------------------- main/FatesInterfaceMod.F90 | 229 ++++++++++++++++++++----- main/FatesInterfaceTypesMod.F90 | 209 ++++++---------------- parteh/PRTLossFluxesMod.F90 | 16 +- 8 files changed, 448 insertions(+), 408 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index f5659dca97..c88e83c1c6 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -985,7 +985,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: leaf_c_target real(r8) :: dynamic_size_fusion_tolerance real(r8) :: dynamic_age_fusion_tolerance - integer :: maxCohortsPerPatch_age_tracking real(r8) :: dbh real(r8) :: leaf_c ! leaf carbon [kg] @@ -1004,11 +1003,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! set the cohort age fusion tolerance (in fraction of years) dynamic_age_fusion_tolerance = ED_val_cohort_age_fusion_tol - if ( hlm_use_cohort_age_tracking .eq. itrue) then - maxCohortsPerPatch_age_tracking = 300 - end if - - !This needs to be a function of the canopy layer, because otherwise, at canopy closure !the number of cohorts doubles and very dissimilar cohorts are fused together @@ -1434,7 +1428,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) if ( hlm_use_cohort_age_tracking .eq.itrue) then - if ( nocohorts > maxCohortsPerPatch_age_tracking ) then + if ( nocohorts > maxCohortsPerPatch ) then iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ae73b6acb8..ca984d16da 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -90,14 +90,6 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 - use FateshydraulicsMemMod, only: wrf_plant, wkf_plant - use FateshydraulicsMemMod, only: alpha_vg - use FateshydraulicsMemMod, only: th_sat_vg - use FateshydraulicsMemMod, only: th_res_vg - use FateshydraulicsMemMod, only: psd_vg - use FateshydraulicsMemMod, only: tort_vg -! use FateshydraulicsMemMod, only: - use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ @@ -183,7 +175,35 @@ module FatesPlantHydraulicsMod __FILE__ - + integer, public, parameter :: van_genuchten_type = 1 + integer, public, parameter :: campbell_type = 2 + integer, public, parameter :: tfs_type = 3 + + integer, parameter :: plant_wrf_type = tfs_type + integer, parameter :: plant_wkf_type = tfs_type + integer, parameter :: soil_wrf_type = campbell_type + integer, parameter :: soil_wkf_type = campbell_type + + + ! Define the global object that holds the water retention functions + ! for plants of each different porous media type, and plant functional type + + class(wrf_arr_type),pointer :: wrf_plant(:,:) + + ! Define the global object that holds the water conductance functions + ! for plants of each different porous media type, and plant functional type + + class(wkf_arr_type), pointer :: wkf_plant(:,:) + + ! Testing parameters for Van Genuchten soil WRTs + ! unused unless van_genuchten_type is selected, also + ! it would be much better to use the native parameters passed in + ! from the HLM's soil model + real(r8), parameter :: alpha_vg = 0.001_r8 + real(r8), parameter :: th_sat_vg = 0.65_r8 + real(r8), parameter :: th_res_vg = 0.15_r8 + real(r8), parameter :: psd_vg = 2.7_r8 + real(r8), parameter :: tort_vg = 0.5_r8 ! The maximum allowable water balance error over a plant-soil continuum ! for a given step [kgs] (0.1 mg) @@ -215,7 +235,7 @@ module FatesPlantHydraulicsMod public :: UpdatePlantHydrLenVol public :: UpdatePlantKmax public :: ConstrainRecruitNumber - + public :: InitHydroGlobals !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen @@ -5174,4 +5194,174 @@ end subroutine SetMaxCondConnections ! ===================================================================================== + subroutine InitHydroGlobals() + + ! This routine allocates the Water Transfer Functions (WTFs) + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for plants! These functions have specific + ! parameters, potentially, for each plant functional type and + ! each organ (pft x organ), but this can be used globally (across + ! all sites on the node (machine) to save memory. These functions + ! are also applied to soils, but since soil properties vary with + ! soil layer and location, those functions are bound to the site + ! structure, and are therefore not "global". + + ! Define + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_tfs), pointer :: wkf_tfs + class(wrf_type_tfs), pointer :: wrf_tfs + + integer :: ft ! PFT index + integer :: pm ! plant media index + integer :: inode ! compartment node index + real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) + real(r8) :: cap_slp ! slope of capillary region of curve + real(r8) :: cap_int ! intercept of capillary region of curve + + if(hlm_use_planthydro.eq.ifalse) return + + ! we allocate from stomata_p_media, which should be zero + + allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) + allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wrf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) + end do + end do + case(campbell_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_cch) + wrf_plant(pm,ft)%p => wrf_cch + call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + 9._r8]) + end do + end do + case(tfs_type) + do ft = 1,numpft + do pm = 1,n_plant_media + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if + + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) + end do + end do + + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(plant_wkf_type) + case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + + end do + case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) + case(tfs_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + end do + end select + + ! There is only 1 stomata conductance hypothesis which uses the p50 and + ! vulnerability parameters + ! ----------------------------------------------------------------------------------- + + do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) + end do + + + return + end subroutine InitHydroGlobals + + !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + + ! This code may be re-introduced at a later date (rgk 08-2019) + + ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP + ! first update the leaf water potential memory + !! do t=2, numLWPmem + !!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) + !!end do + !!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) + !!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + + !!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 + !!do k=1,n_hypool_ag + !!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) + !!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling + !! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & + !! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) + !!end if + !!end do + !!do k=1,n_hypool_troot + !!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) + !!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling + !! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & + !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) + !!end if + !!end do + !!do j=1,site_hydr%nlevrhiz + !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) + !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & + !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling + !! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & + !! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) + !!end if + !!end do + !!end subroutine UpdateLWPMemFLCMin + + + end module FatesPlantHydraulicsMod diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 1098e8eda5..0c77539815 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -85,7 +85,6 @@ module EDInitMod public :: init_site_vars public :: init_patches public :: set_site_properties - public :: InitFatesGlobals private :: init_cohorts diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 913c1a8ef5..5cb4480e4f 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -10,7 +10,7 @@ module EDTypesMod use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : repro_organ, store_organ, struct_organ use PRTGenericMod, only : all_carbon_elements - use PRTGenericMod, only : num_organ_types + use PRTGenericMod, only : num_element_types use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories @@ -23,7 +23,7 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! - integer, parameter, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch + integer, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy @@ -189,7 +189,7 @@ module EDTypesMod ! in PRTGenericMod.F90. examples are carbon12_element ! nitrogen_element, etc. - integer, public :: element_pos(num_organ_types) ! This is the reverse lookup + integer, public :: element_pos(num_element_types) ! This is the reverse lookup ! for element types. Pick an element ! global index, and it gives you ! the position in the element_list diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 68793aeb1e..9d5c18bfa5 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -64,37 +64,6 @@ module FatesHydraulicsMemMod ! Should we ignore the first soil layer and have root layers start on the second? logical, parameter, public :: ignore_layer1=.true. - - integer, public, parameter :: van_genuchten_type = 1 - integer, public, parameter :: campbell_type = 2 - integer, public, parameter :: tfs_type = 3 - - integer, parameter :: plant_wrf_type = tfs_type - integer, parameter :: plant_wkf_type = tfs_type - integer, parameter :: soil_wrf_type = campbell_type - integer, parameter :: soil_wkf_type = campbell_type - - - ! Define the global object that holds the water retention functions - ! for plants of each different porous media type, and plant functional type - - class(wrf_arr_type),pointer :: wrf_plant(:,:) - - ! Define the global object that holds the water conductance functions - ! for plants of each different porous media type, and plant functional type - - class(wkf_arr_type), pointer :: wkf_plant(:,:) - - ! Testing parameters for Van Genuchten soil WRTs - ! unused unless van_genuchten_type is selected, also - ! it would be much better to use the native parameters passed in - ! from the HLM's soil model - real(r8), parameter :: alpha_vg = 0.001_r8 - real(r8), parameter :: th_sat_vg = 0.65_r8 - real(r8), parameter :: th_res_vg = 0.15_r8 - real(r8), parameter :: psd_vg = 2.7_r8 - real(r8), parameter :: tort_vg = 0.5_r8 - ! Derived parameters @@ -105,10 +74,6 @@ module FatesHydraulicsMemMod ! single individual at different layer (kg H2o/m2) real(r8), public :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) - - public :: InitHydroGlobals - - type, public :: ed_site_hydr_type ! Plant Hydraulics @@ -612,148 +577,6 @@ subroutine SetConnections(this) end if end subroutine SetConnections - - ! ==================================================================================== - - subroutine InitHydroGlobals(numpft) - - use FatesHydroWTFMod, only : wrf_arr_type - use FatesHydroWTFMod, only : wkf_arr_type - use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs - use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs - use EDPftvarcon, only : EDPftvarcon_inst - use EDParamsMod, only : hydr_psi0 - use EDParamsMod, only : hydr_psicap - - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - integer,intent(in) :: numpft - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_tfs), pointer :: wkf_tfs - class(wrf_type_tfs), pointer :: wrf_tfs - - integer :: ft ! PFT index - integer :: pm ! plant media index - integer :: inode ! compartment node index - real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) - real(r8) :: cap_slp ! slope of capillary region of curve - real(r8) :: cap_int ! intercept of capillary region of curve - - if(hlm_use_planthydro.eq.ifalse) return - ! we allocate from stomata_p_media, which should be zero - - allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) - allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wrf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wrf_vg) - wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - end do - case(campbell_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_cch) - wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - 9._r8]) - end do - end do - case(tfs_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_tfs) - wrf_plant(pm,ft)%p => wrf_tfs - - if (pm.eq.leaf_p_media) then ! Leaf tissue - cap_slp = 0.0_r8 - cap_int = 0.0_r8 - cap_corr = 1.0_r8 - else ! Non leaf tissues - cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int = -cap_slp + hydr_psi0 - cap_corr = -cap_int/cap_slp - end if - - call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_resid_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - EDPftvarcon_inst%hydr_epsil_node(ft,pm), & - rwcft(pm), & - cap_corr, & - cap_int, & - cap_slp,real(pm,r8)]) - end do - end do - - end select - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(plant_wkf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_vg) - wkf_plant(pm,ft)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - - end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_tfs) - wkf_plant(pm,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & - EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) - end do - end do - end select - - ! There is only 1 stomata conductance hypothesis which uses the p50 and - ! vulnerability parameters - ! ----------------------------------------------------------------------------------- - - do ft = 1,numpft - allocate(wkf_tfs) - wkf_plant(stomata_p_media,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & - EDPftvarcon_inst%hydr_avuln_gs(ft)]) - end do - - - return - end subroutine InitHydroGlobals - end module FatesHydraulicsMemMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 207b0f09fe..41a7455520 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -9,58 +9,71 @@ module FatesInterfaceMod ! which is allocated by thread ! ------------------------------------------------------------------------------------ - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : maxPatchesPerSite - use EDTypesMod , only : maxCohortsPerPatch - use EDTypesMod , only : maxSWb - use EDTypesMod , only : ivis - use EDTypesMod , only : inir - use EDTypesMod , only : nclmax - use EDTypesMod , only : nlevleaf - use EDTypesMod , only : maxpft - use EDTypesMod , only : do_fates_salinity - use EDTypesMod , only : numWaterMem - use EDTypesMod , only : numlevsoil_max - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list - use FatesConstantsMod , only : r8 => fates_r8 - use FatesConstantsMod , only : itrue,ifalse - use FatesGlobals , only : fates_global_verbose - use FatesGlobals , only : fates_log - use FatesGlobals , only : endrun => fates_endrun - use FatesLitterMod , only : ncwd - use FatesLitterMod , only : ndcmpy - use EDPftvarcon , only : FatesReportPFTParams - use EDPftvarcon , only : FatesCheckParams - use EDPftvarcon , only : EDPftvarcon_inst - use SFParamsMod , only : SpitFireCheckParams - use EDParamsMod , only : FatesReportParams - use EDParamsMod , only : bgc_soil_salinity - use PRTGenericMod , only : prt_carbon_allom_hyp - use PRTGenericMod , only : prt_cnp_flex_allom_hyp - use HydraulicsMemMod , only : InitHydroGlobals - use EDParamsMod, only : ED_val_history_sizeclass_bin_edges, ED_val_history_ageclass_bin_edges - use EDParamsMod, only : ED_val_history_height_bin_edges - use EDParamsMod, only : ED_val_history_coageclass_bin_edges - use CLMFatesParamInterfaceMod , only : FatesReadParameters + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxPatchesPerSite + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : maxSWb + use EDTypesMod , only : ivis + use EDTypesMod , only : inir + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevleaf + use EDTypesMod , only : maxpft + use EDTypesMod , only : do_fates_salinity + use EDTypesMod , only : numWaterMem + use EDTypesMod , only : numlevsoil_max + use EDTypesMod , only : num_elements + use EDTypesMod , only : element_list + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue,ifalse + use FatesGlobals , only : fates_global_verbose + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use FatesLitterMod , only : ncwd + use FatesLitterMod , only : ndcmpy + use EDPftvarcon , only : FatesReportPFTParams + use EDPftvarcon , only : FatesCheckParams + use EDPftvarcon , only : EDPftvarcon_inst + use SFParamsMod , only : SpitFireCheckParams + use EDParamsMod , only : FatesReportParams + use EDParamsMod , only : bgc_soil_salinity + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + use PRTGenericMod , only : carbon12_element + use PRTGenericMod , only : nitrogen_element + use PRTGenericMod , only : phosphorus_element + use EDTypesMod , only : element_pos, element_list + use FatesPlantHydraulicsMod , only : InitHydroGlobals + use EDParamsMod , only : ED_val_history_sizeclass_bin_edges + use EDParamsMod , only : ED_val_history_ageclass_bin_edges + use EDParamsMod , only : ED_val_history_height_bin_edges + use EDParamsMod , only : ED_val_history_coageclass_bin_edges + use CLMFatesParamInterfaceMod , only : FatesReadParameters + use PRTAllometricCarbonMod , only : InitPRTGlobalAllometricCarbon ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) ! Just use everything from FatesInterfaceTypesMod, this is ! its sister code use FatesInterfaceTypesMod + implicit none + + character(len=*), parameter :: sourcefile = & + __FILE__ + + ! Make public necessary subroutines and functions public :: FatesInterfaceInit public :: set_fates_ctrlparms public :: SetFatesTime - public :: set_fates_global_elements + public :: SetFatesGlobalElements public :: FatesReportParameters public :: allocate_bcin public :: allocate_bcout + public :: zero_bcs contains @@ -99,8 +112,123 @@ subroutine fates_clean(this) end subroutine fates_clean - ! ==================================================================================== - + ! ==================================================================================== + + subroutine zero_bcs(fates,s) + + type(fates_interface_type), intent(inout) :: fates + integer, intent(in) :: s + + ! Input boundaries + + fates%bc_in(s)%t_veg24_si = 0.0_r8 + fates%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + fates%bc_in(s)%precip24_pa(:) = 0.0_r8 + fates%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + fates%bc_in(s)%wind24_pa(:) = 0.0_r8 + + fates%bc_in(s)%solad_parb(:,:) = 0.0_r8 + fates%bc_in(s)%solai_parb(:,:) = 0.0_r8 + fates%bc_in(s)%smp_sl(:) = 0.0_r8 + fates%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 + fates%bc_in(s)%watsat_sl(:) = 0.0_r8 + fates%bc_in(s)%tempk_sl(:) = 0.0_r8 + fates%bc_in(s)%h2o_liqvol_sl(:) = 0.0_r8 + fates%bc_in(s)%filter_vegzen_pa(:) = .false. + fates%bc_in(s)%coszen_pa(:) = 0.0_r8 + fates%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 + fates%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 + fates%bc_in(s)%max_rooting_depth_index_col = 0 + fates%bc_in(s)%tot_het_resp = 0.0_r8 + fates%bc_in(s)%tot_somc = 0.0_r8 + fates%bc_in(s)%tot_litc = 0.0_r8 + fates%bc_in(s)%snow_depth_si = 0.0_r8 + fates%bc_in(s)%frac_sno_eff_si = 0.0_r8 + + if(do_fates_salinity)then + fates%bc_in(s)%salinity_sl(:) = 0.0_r8 + endif + + if (hlm_use_planthydro.eq.itrue) then + + fates%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 + fates%bc_in(s)%swrad_net_pa(:) = 0.0_r8 + fates%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 + fates%bc_in(s)%watsat_sisl(:) = 0.0_r8 + fates%bc_in(s)%watres_sisl(:) = 0.0_r8 + fates%bc_in(s)%sucsat_sisl(:) = 0.0_r8 + fates%bc_in(s)%bsw_sisl(:) = 0.0_r8 + fates%bc_in(s)%hksat_sisl(:) = 0.0_r8 + end if + + + ! Output boundaries + fates%bc_out(s)%active_suction_sl(:) = .false. + fates%bc_out(s)%fsun_pa(:) = 0.0_r8 + fates%bc_out(s)%laisun_pa(:) = 0.0_r8 + fates%bc_out(s)%laisha_pa(:) = 0.0_r8 + fates%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 + fates%bc_out(s)%btran_pa(:) = 0.0_r8 + + ! Fates -> BGC fragmentation mass fluxes + select case(hlm_parteh_mode) + case(prt_carbon_allom_hyp) + fates%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 + case(prt_cnp_flex_allom_hyp) + fates%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_cel_n_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lig_n_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lab_n_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 + fates%bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 + case default + write(fates_log(), *) 'An unknown parteh hypothesis was passed' + write(fates_log(), *) 'while zeroing output boundary conditions' + write(fates_log(), *) 'hlm_parteh_mode: ',hlm_parteh_mode + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + + + fates%bc_out(s)%rssun_pa(:) = 0.0_r8 + fates%bc_out(s)%rssha_pa(:) = 0.0_r8 + + fates%bc_out(s)%albd_parb(:,:) = 0.0_r8 + fates%bc_out(s)%albi_parb(:,:) = 0.0_r8 + fates%bc_out(s)%fabd_parb(:,:) = 0.0_r8 + fates%bc_out(s)%fabi_parb(:,:) = 0.0_r8 + fates%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 + fates%bc_out(s)%ftid_parb(:,:) = 0.0_r8 + fates%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + + fates%bc_out(s)%elai_pa(:) = 0.0_r8 + fates%bc_out(s)%esai_pa(:) = 0.0_r8 + fates%bc_out(s)%tlai_pa(:) = 0.0_r8 + fates%bc_out(s)%tsai_pa(:) = 0.0_r8 + fates%bc_out(s)%htop_pa(:) = 0.0_r8 + fates%bc_out(s)%hbot_pa(:) = 0.0_r8 + fates%bc_out(s)%displa_pa(:) = 0.0_r8 + fates%bc_out(s)%z0m_pa(:) = 0.0_r8 + fates%bc_out(s)%dleaf_pa(:) = 0.0_r8 + + fates%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 + fates%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 + + if (hlm_use_planthydro.eq.itrue) then + fates%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 + fates%bc_out(s)%qflx_ro_sisl(:) = 0.0_r8 + end if + fates%bc_out(s)%plant_stored_h2o_si = 0.0_r8 + + return + end subroutine zero_bcs + + ! =========================================================================== subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in) @@ -344,7 +472,7 @@ end subroutine set_bcs ! =================================================================================== - subroutine set_fates_global_elements(use_fates) + subroutine SetFatesGlobalElements(use_fates) ! -------------------------------------------------------------------------------- ! @@ -366,11 +494,10 @@ subroutine set_fates_global_elements(use_fates) implicit none logical,intent(in) :: use_fates ! Is fates turned on? - integer :: i if (use_fates) then - + ! first read the non-PFT parameters call FatesReadParameters() @@ -386,7 +513,7 @@ subroutine set_fates_global_elements(use_fates) write(fates_log(), *) 'it was found that the lower bound was neither 0 or 1?' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(numpft>maxpft) then write(fates_log(), *) 'The number of PFTs dictated by the FATES parameter file' write(fates_log(), *) 'is larger than the maximum allowed. Increase the FATES parameter constant' @@ -404,6 +531,18 @@ subroutine set_fates_global_elements(use_fates) else nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) end if + + ! These values are used to define the restart file allocations and general structure + ! of memory for the cohort arrays + + if ( hlm_use_cohort_age_tracking .eq. itrue) then + maxCohortsPerPatch = 300 + else + maxCohortsPerPatch = 100 + end if + + fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*numlevsoil_max ,ncwd*numlevsoil_max) + ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays @@ -469,7 +608,7 @@ subroutine set_fates_global_elements(use_fates) ! (like water retention functions) ! this needs to know the number of PFTs, which is ! determined in that call - call InitHydroGlobals(numpft) + call InitHydroGlobals() ! Initialize the Plant Allocation and Reactive Transport ! global functions and mapping tables @@ -498,7 +637,7 @@ subroutine set_fates_global_elements(use_fates) end if - end subroutine set_fates_global_elements + end subroutine SetFatesGlobalElements ! ====================================================================== diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index a7bd57ea70..ff9a33d08a 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -1,4 +1,14 @@ module FatesInterfaceTypesMod + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue,ifalse + use FatesGlobals , only : fates_global_verbose + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use EDTypesMod , only : ed_site_type + implicit none private ! By default everything is private @@ -12,26 +22,26 @@ module FatesInterfaceTypesMod ! ------------------------------------------------------------------------------------- - integer, public, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation + integer, public :: hlm_numSWb ! Number of broad-bands in the short-wave radiation ! specturm to track ! (typically 2 as a default, VIS/NIR, in ED variants <2016) - integer, public, protected :: hlm_ivis ! The HLMs assumption of the array index associated with the + integer, public :: hlm_ivis ! The HLMs assumption of the array index associated with the ! visible portion of the spectrum in short-wave radiation arrays - integer, public, protected :: hlm_inir ! The HLMs assumption of the array index associated with the + integer, public :: hlm_inir ! The HLMs assumption of the array index associated with the ! NIR portion of the spectrum in short-wave radiation arrays - integer, public, protected :: hlm_numlevgrnd ! Number of ground layers + integer, public :: hlm_numlevgrnd ! Number of ground layers ! NOTE! SOIL LAYERS ARE NOT A GLOBAL, THEY ! ARE VARIABLE BY SITE - integer, public, protected :: hlm_is_restart ! Is the HLM signalling that this is a restart + integer, public :: hlm_is_restart ! Is the HLM signalling that this is a restart ! type simulation? ! 1=TRUE, 0=FALSE - character(len=16), public, protected :: hlm_name ! This character string passed by the HLM + character(len=16), public :: hlm_name ! This character string passed by the HLM ! is used during the processing of IO data, ! so that FATES knows which IO variables it ! should prepare. For instance @@ -40,24 +50,24 @@ module FatesInterfaceTypesMod ! This string sets which filter is enacted. - real(r8), public, protected :: hlm_hio_ignore_val ! This value can be flushed to history + real(r8), public :: hlm_hio_ignore_val ! This value can be flushed to history ! diagnostics, such that the ! HLM will interpret that the value should not ! be included in the average. - integer, public, protected :: hlm_masterproc ! Is this the master processor, typically useful + integer, public :: hlm_masterproc ! Is this the master processor, typically useful ! for knowing if the current machine should be ! printing out messages to the logs or terminals ! 1 = TRUE (is master) 0 = FALSE (is not master) - integer, public, protected :: hlm_ipedof ! The HLM pedotransfer index + integer, public :: hlm_ipedof ! The HLM pedotransfer index ! this is only used by the plant hydraulics ! submodule to check and/or enable consistency ! between the pedotransfer functions of the HLM ! and how it moves and stores water in its ! rhizosphere shells - integer, public, protected :: hlm_max_patch_per_site ! The HLM needs to exchange some patch + integer, public :: hlm_max_patch_per_site ! The HLM needs to exchange some patch ! level quantities with FATES ! FATES does not dictate those allocations ! since it happens pretty early in @@ -66,31 +76,31 @@ module FatesInterfaceTypesMod ! compare it to our maxpatchpersite, ! and gracefully halt if we are over-allocating - integer, public, protected :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive + integer, public :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive ! Transport (exensible) Hypothesis (PARTEH) to use - integer, public, protected :: hlm_use_vertsoilc ! This flag signals whether or not the + integer, public :: hlm_use_vertsoilc ! This flag signals whether or not the ! host model is using vertically discretized ! soil carbon ! 1 = TRUE, 0 = FALSE - integer, public, protected :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE + integer, public :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE ! 1 = TRUE, 0 = FALSE - integer, public, protected :: hlm_use_logging ! This flag signals whether or not to use + integer, public :: hlm_use_logging ! This flag signals whether or not to use ! the logging module - integer, public, protected :: hlm_use_planthydro ! This flag signals whether or not to use + integer, public :: hlm_use_planthydro ! This flag signals whether or not to use ! plant hydraulics (bchristo/xu methods) ! 1 = TRUE, 0 = FALSE ! THIS IS CURRENTLY NOT SUPPORTED - integer, public, protected :: hlm_use_cohort_age_tracking ! This flag signals whether or not to use + integer, public :: hlm_use_cohort_age_tracking ! This flag signals whether or not to use ! cohort age tracking. 1 = TRUE, 0 = FALSE - integer, public, protected :: hlm_use_ed_st3 ! This flag signals whether or not to use + integer, public :: hlm_use_ed_st3 ! This flag signals whether or not to use ! (ST)atic (ST)and (ST)ructure mode (ST3) ! Essentially, this gives us the ability ! to turn off "dynamics", ie growth, disturbance @@ -100,7 +110,7 @@ module FatesInterfaceTypesMod ! default should be FALSE (dynamics on) ! cannot be true with prescribed_phys - integer, public, protected :: hlm_use_ed_prescribed_phys ! This flag signals whether or not to use + integer, public :: hlm_use_ed_prescribed_phys ! This flag signals whether or not to use ! prescribed physiology, somewhat the opposite ! to ST3, in this case can turn off ! fast processes like photosynthesis and respiration @@ -110,13 +120,13 @@ module FatesInterfaceTypesMod ! default should be FALSE (biophysics on) ! cannot be true with st3 mode - integer, public, protected :: hlm_use_inventory_init ! Initialize this simulation from + integer, public :: hlm_use_inventory_init ! Initialize this simulation from ! an inventory file. If this is toggled on ! an inventory control file must be specified ! as well. ! 1 = TRUE, 0 = FALSE - character(len=256), public, protected :: hlm_inventory_ctrl_file ! This is the full path to the + character(len=256), public :: hlm_inventory_ctrl_file ! This is the full path to the ! inventory control file that ! specifieds the availabel inventory datasets ! there locations and their formats @@ -130,7 +140,7 @@ module FatesInterfaceTypesMod ! Variables mostly used for dimensioning host land model (HLM) array spaces - integer, public, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + integer, public :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately ! used to set the size of the largest arrays necessary ! in things like restart files (probably hosted by the ! HLM). The size of these arrays are not a parameter @@ -139,7 +149,7 @@ module FatesInterfaceTypesMod ! maximum number of cohorts per patch, but ! but it could be other things. - integer, public, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per + integer, public :: fates_maxElementsPerSite ! This is the max number of individual items one can store per ! each grid cell and effects the striding in the ED restart ! data as some fields are arrays where each array is ! associated with one cohort @@ -198,17 +208,17 @@ module FatesInterfaceTypesMod ! It is assumed that all of the sites on a given machine will be synchronous. ! It is also assumed that the HLM will control time. ! ------------------------------------------------------------------------------------- - integer, public, protected :: hlm_current_year ! Current year - integer, public, protected :: hlm_current_month ! month of year - integer, public, protected :: hlm_current_day ! day of month - integer, public, protected :: hlm_current_tod ! time of day (seconds past 0Z) - integer, public, protected :: hlm_current_date ! time of day (seconds past 0Z) - integer, public, protected :: hlm_reference_date ! YYYYMMDD - real(r8), public, protected :: hlm_model_day ! elapsed days between current date and ref - integer, public, protected :: hlm_day_of_year ! The integer day of the year - integer, public, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may + integer, public :: hlm_current_year ! Current year + integer, public :: hlm_current_month ! month of year + integer, public :: hlm_current_day ! day of month + integer, public :: hlm_current_tod ! time of day (seconds past 0Z) + integer, public :: hlm_current_date ! time of day (seconds past 0Z) + integer, public :: hlm_reference_date ! YYYYMMDD + real(r8), public :: hlm_model_day ! elapsed days between current date and ref + integer, public :: hlm_day_of_year ! The integer day of the year + integer, public :: hlm_days_per_year ! The HLM controls time, some HLMs may ! include a leap - real(r8), public, protected :: hlm_freq_day ! fraction of year for daily time-step + real(r8), public :: hlm_freq_day ! fraction of year for daily time-step ! (1/days_per_year_, this is a frequency @@ -218,12 +228,12 @@ module FatesInterfaceTypesMod ! ! ------------------------------------------------------------------------------------- - integer, public, protected :: numpft ! The total number of PFTs defined in the simulation - integer, public, protected :: nlevsclass ! The total number of cohort size class bins output to history - integer, public, protected :: nlevage ! The total number of patch age bins output to history - integer, public, protected :: nlevheight ! The total number of height bins output to history - integer, public, protected :: nlevcoage ! The total number of cohort age bins output to history - integer, public, protected :: nleafage ! The total number of leaf age classes + integer, public :: numpft ! The total number of PFTs defined in the simulation + integer, public :: nlevsclass ! The total number of cohort size class bins output to history + integer, public :: nlevage ! The total number of patch age bins output to history + integer, public :: nlevheight ! The total number of height bins output to history + integer, public :: nlevcoage ! The total number of cohort age bins output to history + integer, public :: nleafage ! The total number of leaf age classes ! ------------------------------------------------------------------------------------- ! Structured Boundary Conditions (SITE/PATCH SCALE) @@ -570,129 +580,14 @@ module FatesInterfaceTypesMod type(bc_out_type), allocatable :: bc_out(:) - contains - - procedure, public :: zero_bcs end type fates_interface_type + contains + ! ==================================================================================== - subroutine zero_bcs(this,s) - - implicit none - class(fates_interface_type), intent(inout) :: this - integer, intent(in) :: s - - ! Input boundaries - - this%bc_in(s)%t_veg24_si = 0.0_r8 - this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 - this%bc_in(s)%precip24_pa(:) = 0.0_r8 - this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 - this%bc_in(s)%wind24_pa(:) = 0.0_r8 - - this%bc_in(s)%solad_parb(:,:) = 0.0_r8 - this%bc_in(s)%solai_parb(:,:) = 0.0_r8 - this%bc_in(s)%smp_sl(:) = 0.0_r8 - this%bc_in(s)%eff_porosity_sl(:) = 0.0_r8 - this%bc_in(s)%watsat_sl(:) = 0.0_r8 - this%bc_in(s)%tempk_sl(:) = 0.0_r8 - this%bc_in(s)%h2o_liqvol_sl(:) = 0.0_r8 - this%bc_in(s)%filter_vegzen_pa(:) = .false. - this%bc_in(s)%coszen_pa(:) = 0.0_r8 - this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 - this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 - this%bc_in(s)%max_rooting_depth_index_col = 0 - this%bc_in(s)%tot_het_resp = 0.0_r8 - this%bc_in(s)%tot_somc = 0.0_r8 - this%bc_in(s)%tot_litc = 0.0_r8 - this%bc_in(s)%snow_depth_si = 0.0_r8 - this%bc_in(s)%frac_sno_eff_si = 0.0_r8 - - if(do_fates_salinity)then - this%bc_in(s)%salinity_sl(:) = 0.0_r8 - endif - - if (hlm_use_planthydro.eq.itrue) then - - this%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 - this%bc_in(s)%swrad_net_pa(:) = 0.0_r8 - this%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 - this%bc_in(s)%watsat_sisl(:) = 0.0_r8 - this%bc_in(s)%watres_sisl(:) = 0.0_r8 - this%bc_in(s)%sucsat_sisl(:) = 0.0_r8 - this%bc_in(s)%bsw_sisl(:) = 0.0_r8 - this%bc_in(s)%hksat_sisl(:) = 0.0_r8 - end if - - - ! Output boundaries - this%bc_out(s)%active_suction_sl(:) = .false. - this%bc_out(s)%fsun_pa(:) = 0.0_r8 - this%bc_out(s)%laisun_pa(:) = 0.0_r8 - this%bc_out(s)%laisha_pa(:) = 0.0_r8 - this%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 - this%bc_out(s)%btran_pa(:) = 0.0_r8 - - ! Fates -> BGC fragmentation mass fluxes - select case(hlm_parteh_mode) - case(prt_carbon_allom_hyp) - this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 - case(prt_cnp_flex_allom_hyp) - this%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 - this%bc_out(s)%litt_flux_cel_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_n_si(:) = 0._r8 - this%bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 - this%bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 - case default - write(fates_log(), *) 'An unknown parteh hypothesis was passed' - write(fates_log(), *) 'while zeroing output boundary conditions' - write(fates_log(), *) 'hlm_parteh_mode: ',hlm_parteh_mode - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - - - this%bc_out(s)%rssun_pa(:) = 0.0_r8 - this%bc_out(s)%rssha_pa(:) = 0.0_r8 - - this%bc_out(s)%albd_parb(:,:) = 0.0_r8 - this%bc_out(s)%albi_parb(:,:) = 0.0_r8 - this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 - this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 - this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 - - this%bc_out(s)%elai_pa(:) = 0.0_r8 - this%bc_out(s)%esai_pa(:) = 0.0_r8 - this%bc_out(s)%tlai_pa(:) = 0.0_r8 - this%bc_out(s)%tsai_pa(:) = 0.0_r8 - this%bc_out(s)%htop_pa(:) = 0.0_r8 - this%bc_out(s)%hbot_pa(:) = 0.0_r8 - this%bc_out(s)%displa_pa(:) = 0.0_r8 - this%bc_out(s)%z0m_pa(:) = 0.0_r8 - this%bc_out(s)%dleaf_pa(:) = 0.0_r8 - - this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 - this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 - - if (hlm_use_planthydro.eq.itrue) then - this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 - this%bc_out(s)%qflx_ro_sisl(:) = 0.0_r8 - end if - this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 - - return - end subroutine zero_bcs - -end module FatesInterfaceTypesMod + + end module FatesInterfaceTypesMod diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index a805d58a96..4e59a4354d 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -18,8 +18,8 @@ module PRTLossFluxesMod use PRTGenericMod, only : check_initialized use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : prt_global - use FatesInterfaceMod, only : hlm_freq_day - + use FatesConstantsMOd, only : years_per_day + use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : i4 => fates_int use FatesConstantsMod, only : nearzero @@ -651,9 +651,9 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! ----------------------------------------------------------------------------------- if ( EDPftvarcon_inst%branch_turnover(ipft) > nearzero ) then - base_turnover(sapw_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) - base_turnover(struct_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) - base_turnover(store_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) + base_turnover(sapw_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) + base_turnover(struct_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) + base_turnover(store_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) else base_turnover(sapw_organ) = 0.0_r8 base_turnover(struct_organ) = 0.0_r8 @@ -664,7 +664,7 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! life-span is selected ! --------------------------------------------------------------------------------- if ( EDPftvarcon_inst%root_long(ipft) > nearzero ) then - base_turnover(fnrt_organ) = hlm_freq_day / EDPftvarcon_inst%root_long(ipft) + base_turnover(fnrt_organ) = years_per_day / EDPftvarcon_inst%root_long(ipft) else base_turnover(fnrt_organ) = 0.0_r8 end if @@ -681,11 +681,11 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) (EDPftvarcon_inst%evergreen(ipft) == itrue) ) then if(is_drought) then - base_turnover(leaf_organ) = hlm_freq_day / & + base_turnover(leaf_organ) = years_per_day / & (EDPftvarcon_inst%leaf_long(ipft,aclass_sen_id) * & EDPftvarcon_inst%senleaf_long_fdrought(ipft) ) else - base_turnover(leaf_organ) = hlm_freq_day / & + base_turnover(leaf_organ) = years_per_day / & EDPftvarcon_inst%leaf_long(ipft,aclass_sen_id) end if else From 3bba389bea71f10873fce95d29be4c02df239bec Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 8 May 2020 12:51:35 -0600 Subject: [PATCH 100/114] made FatesInterfaceMod private again. Removed redundant calculation of max elements --- main/FatesInterfaceMod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0eb4f864f6..32b36a9ec1 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -61,6 +61,8 @@ module FatesInterfaceMod implicit none + private + character(len=*), parameter :: sourcefile = & __FILE__ @@ -539,9 +541,6 @@ subroutine SetFatesGlobalElements(use_fates) else maxCohortsPerPatch = 100 end if - - fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*numlevsoil_max ,ncwd*numlevsoil_max) - ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays From 4f8b675e2474fae7b9ed153f6cc8a6bd2d7f9916 Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 11 May 2020 11:54:23 -0700 Subject: [PATCH 101/114] added .zenodo.json with 'FATES Development Team' as author --- .zenodo.json | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 .zenodo.json diff --git a/.zenodo.json b/.zenodo.json new file mode 100644 index 0000000000..c60f213947 --- /dev/null +++ b/.zenodo.json @@ -0,0 +1,9 @@ +{ + "title": "The Functionally Assembled Terrestrial Ecosystem Simulator (FATES)", + "creators": [ + { + "name": "FATES Development Team" + } + ], + "license":"BSD", +} \ No newline at end of file From 430c8c8a50458b5b980bb8313b8586fd05b1061b Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 11 May 2020 11:55:55 -0700 Subject: [PATCH 102/114] added .zenodo.json with 'FATES Development Team' as author --- .zenodo.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.zenodo.json b/.zenodo.json index c60f213947..e55f0b1c3c 100644 --- a/.zenodo.json +++ b/.zenodo.json @@ -5,5 +5,5 @@ "name": "FATES Development Team" } ], - "license":"BSD", + "license":"BSD" } \ No newline at end of file From e0163693cc7370bfeae3481a42b4080dda92fdee Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Mon, 11 May 2020 12:05:51 -0700 Subject: [PATCH 103/114] added .zenodo.json with 'FATES Development Team' as author --- .zenodo.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.zenodo.json b/.zenodo.json index e55f0b1c3c..d06ffc70f9 100644 --- a/.zenodo.json +++ b/.zenodo.json @@ -6,4 +6,4 @@ } ], "license":"BSD" -} \ No newline at end of file +} From 5b7bd67843942ffa436eae209f14bdd958858031 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 11 May 2020 13:47:09 -0600 Subject: [PATCH 104/114] Syntax updates per Gregs review --- main/EDInitMod.F90 | 3 --- parteh/PRTLossFluxesMod.F90 | 3 +-- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0c77539815..ea342f0e68 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -66,9 +66,6 @@ module EDInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState -!! use FatesPlantHydraulicsMod, only : InitHydroGlobals - use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon -! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index 4e59a4354d..49125304f3 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -18,8 +18,7 @@ module PRTLossFluxesMod use PRTGenericMod, only : check_initialized use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : prt_global - use FatesConstantsMOd, only : years_per_day - + use FatesConstantsMod, only : years_per_day use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : i4 => fates_int use FatesConstantsMod, only : nearzero From 626ca9bd40133322c4131ec93e961d4f2480a2e1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 12 May 2020 22:40:16 -0700 Subject: [PATCH 105/114] change license field in zenodo to specific license name definition --- .zenodo.json | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.zenodo.json b/.zenodo.json index d06ffc70f9..757a4dc57d 100644 --- a/.zenodo.json +++ b/.zenodo.json @@ -5,5 +5,5 @@ "name": "FATES Development Team" } ], - "license":"BSD" + "license":"BSD-3-Clause" } From 01adcd5824ffe97da4657aed72d370e47ec0b39a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 13 May 2020 12:42:50 -0700 Subject: [PATCH 106/114] adding DOI badge --- README.md | 1 + 1 file changed, 1 insertion(+) diff --git a/README.md b/README.md index 423fc32321..cc70e6138d 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # FATES ------------------------------ +[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825474.svg)](https://doi.org/10.5281/zenodo.3825474) This repository holds the Functionally Assembled Terrestrial Ecosystem Simulator (FATES). FATES is a numerical terrestrial ecosystem model. Its development and support is primarily supported by the Department of Energy's Office of Science, through the Next Generation Ecosystem Experiment - Tropics ([NGEE-T](https://ngee-tropics.lbl.gov/)) project. From 7fe3969fe00847edf06cc0315f77d37d1fb378bc Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 13 May 2020 12:45:24 -0700 Subject: [PATCH 107/114] manually correcting badge to use all versions DOI --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index cc70e6138d..e3886bc268 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # FATES ------------------------------ -[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825474.svg)](https://doi.org/10.5281/zenodo.3825474) +[![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825473.svg)](https://doi.org/10.5281/zenodo.3825473) This repository holds the Functionally Assembled Terrestrial Ecosystem Simulator (FATES). FATES is a numerical terrestrial ecosystem model. Its development and support is primarily supported by the Department of Energy's Office of Science, through the Next Generation Ecosystem Experiment - Tropics ([NGEE-T](https://ngee-tropics.lbl.gov/)) project. From 9876102cf6b683397641e1ed74eaa73f0d22aa1d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 11:40:12 -0700 Subject: [PATCH 108/114] making set_bcs public as it was missed in PR647 --- main/FatesInterfaceMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 24ecd9ea2b..2361c835d6 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -76,6 +76,7 @@ module FatesInterfaceMod public :: allocate_bcin public :: allocate_bcout public :: zero_bcs + public :: set_bcs contains From 87de44662e6af2ca203ab0163a03bee5317749ac Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 11:48:57 -0700 Subject: [PATCH 109/114] removing dead code from PR647 --- main/EDInitMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b34f838598..ab86f65aec 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -35,7 +35,6 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston - use EDTypesMod , only : element_pos use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init From 9b7f66c7ccba3d0b17f5b735abd4eb6b8875994a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 13:56:13 -0600 Subject: [PATCH 110/114] reinstating pft_areafrac to FatesInterfaceTypeMod after it was deleted in deconflict --- main/FatesInterfaceTypesMod.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index ecc1624ec0..69465d1784 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -423,7 +423,10 @@ module FatesInterfaceTypesMod real(r8),allocatable :: hksat_sisl(:) ! hydraulic conductivity at saturation (mm H2O /s) real(r8),allocatable :: h2o_liq_sisl(:) ! Liquid water mass in each layer (kg/m2) real(r8) :: smpmin_si ! restriction for min of soil potential (mm) - + + ! Fixed biogeography mode + real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT + end type bc_in_type From b235e967897e5fee03a0223d0576fb53530cc7f6 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 14:08:46 -0600 Subject: [PATCH 111/114] reinstating hlm_use_fixed_biogeog to FatesInterfaceTypeMod after being trampled in merge deconflict --- main/FatesInterfaceTypesMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 69465d1784..1b3dce4bd8 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -133,6 +133,9 @@ module FatesInterfaceTypesMod ! This need only be defined when ! hlm_use_inventory_init = 1 + integer, public :: hlm_use_fixed_biogeog ! Flag to use FATES fixed biogeography mode + ! 1 = TRUE, 0 = FALSE + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs From 66c2cc8094cc1e3e68d34f719928d6cee8b452c3 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 14:24:38 -0600 Subject: [PATCH 112/114] commenting out nocomp for future reduced complexity mode --- main/FatesInterfaceMod.F90 | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2361c835d6..1fddc28def 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -991,7 +991,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_ed_st3 = unset_int hlm_use_ed_prescribed_phys = unset_int hlm_use_fixed_biogeog = unset_int - hlm_use_nocomp = unset_int + !hlm_use_nocomp = unset_int ! future reduced complexity mode hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' @@ -1199,12 +1199,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_nocomp.eq.unset_int) then - if(fates_global_verbose()) then - write(fates_log(), *) 'switch for no competition mode. ' - end if - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! Future reduced complexity mode + !if(hlm_use_nocomp.eq.unset_int) then + ! if(fates_global_verbose()) then + ! write(fates_log(), *) 'switch for no competition mode. ' + ! end if + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then @@ -1295,12 +1296,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',ival,' to FATES' end if - - case('use_nocomp') - hlm_use_nocomp = ival - if (fates_global_verbose()) then - write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' - end if + + ! Future reduced complexity mode + !case('use_nocomp') + ! hlm_use_nocomp = ival + ! if (fates_global_verbose()) then + ! write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + ! end if case('use_planthydro') From 111e24cb961e39eeb59afa705ba17b2ed8fb9653 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 14:36:27 -0600 Subject: [PATCH 113/114] commenting out what looks like future code --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index c4a6d8b765..7f58c73514 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1206,7 +1206,7 @@ subroutine SeedIn( currentSite, bc_in ) ! !USES: use EDTypesMod, only : area use EDTypesMod, only : homogenize_seed_pfts - use FatesInterfaceMod, only : hlm_use_fixed_biogeog + !use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog ! For future reduced complexity? ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite From 0ffab8bb75e88d05c822711a7808038dbf5a5dd8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 19 May 2020 14:44:40 -0600 Subject: [PATCH 114/114] reinstating hlm_use_fixed_biogeog to EDInitMod that got trampled during merge --- main/EDInitMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ab86f65aec..646084ef1b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -38,6 +38,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass