diff --git a/.zenodo.json b/.zenodo.json new file mode 100644 index 0000000000..757a4dc57d --- /dev/null +++ b/.zenodo.json @@ -0,0 +1,9 @@ +{ + "title": "The Functionally Assembled Terrestrial Ecosystem Simulator (FATES)", + "creators": [ + { + "name": "FATES Development Team" + } + ], + "license":"BSD-3-Clause" +} diff --git a/README.md b/README.md index 423fc32321..e3886bc268 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ # FATES ------------------------------ +[![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. 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 09af1236a8..c88e83c1c6 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,17 +38,18 @@ 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 : 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 : UpdateTreeHydrLenVolCond + use FatesPlantHydraulicsMod, only : UpdatePlantHydrNodes + use FatesPlantHydraulicsMod, only : UpdatePlantHydrLenVol + use FatesPlantHydraulicsMod, only : UpdatePlantKmax use FatesPlantHydraulicsMod, only : SavePreviousCompartmentVolumes use FatesPlantHydraulicsMod, only : ConstrainRecruitNumber use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index @@ -188,7 +189,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, 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 !---------------------------------------------------------------------- @@ -300,25 +301,28 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, 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) + call UpdatePlantHydrNodes(new_cohort%co_hydr,new_cohort%pft, & + new_cohort%hite,currentSite%si_hydr) - ! This calculates volumes, lengths and max conductances - call UpdateTreeHydrLenVolCond(new_cohort,nlevsoi_hyd,bc_in) + ! This calculates volumes and lengths + 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) + ! 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) ! This comes up with starter suctions and then water contents ! based on the soil values - call initTreeHydStates(currentSite,new_cohort, bc_in) + call InitPlantHydStates(currentSite,new_cohort) if(recruitstatus==1)then @@ -949,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 @@ -981,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] @@ -1000,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 @@ -1386,12 +1384,13 @@ 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) deallocate(nextc) nullify(nextc) + endif ! if( currentCohort%isnew.eqv.nextc%isnew ) then endif !canopy layer @@ -1429,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/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 2a99cfb485..2c5cbdd0d5 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 @@ -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 @@ -128,9 +128,9 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor 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 @@ -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 @@ -217,7 +218,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 78c50c0f93..7f58c73514 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 @@ -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 @@ -612,8 +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 - temp_in_C = bc_in%t_veg24_si - 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 @@ -663,8 +671,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 @@ -1198,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 @@ -1423,8 +1431,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 @@ -2113,7 +2120,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) @@ -2230,9 +2237,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/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 new file mode 100644 index 0000000000..acae6e3e41 --- /dev/null +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -0,0 +1,1167 @@ +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 + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + + 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). + ! ------------------------------------------------------------------------------------- + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + 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 + + 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 + + type, public :: wrf_type + 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 + + + ! Generic class that can be extended to describe + ! water conductance functions + + type, public :: wkf_type + 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 + + ! The WRF and WKF types cannot be arrays themselves + ! we require these holders + + type, public :: wrf_arr_type + class(wrf_type), pointer :: p + 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 + + + ! ===================================================================================== + ! Van Genuchten WTF Definitions + ! ===================================================================================== + + ! Water Retention Function + type, public, extends(wrf_type) :: wrf_type_vg + 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] + + 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 :: 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 [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] + 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 [-] + 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 + 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 + + ! ===================================================================================== + ! 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) :: 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 + integer :: pmedia ! self describing porous media index + + 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_sf_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 + type, public, extends(wkf_type) :: wkf_type_tfs + 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 + + ! ===================================================================================== + ! Functional definitions follow here + ! Start off by writing the base types, which ultimately should never be pointed to. + ! ===================================================================================== + + 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(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(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(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(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,params_in) + + class(wrf_type_vg) :: this + 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) + + 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(:) + + 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(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 [-] + real(r8) :: th ! Volumetric Water Cont [m3/m3] + + 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) + + m = 1._r8/this%psd + + ! pressure above which we use a linear function + psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(m-1._r8)) - 1._r8 )**m + + if(psi=max_sf_interp) then + + 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_sf_interp**(1._r8/(m-1._r8)) - 1._r8 )**m + psi = psi_interp + dpsidth_interp*(th-th_interp) + + else + + psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + + + end if + + end function psi_from_th_vg + + ! ===================================================================================== + + function dpsidth_from_th_vg(this,th) result(dpsidth) + + class(wrf_type_vg) :: this + real(r8),intent(in) :: th ! water content + real(r8) :: a1 ! parameter intermediary + real(r8) :: m1 ! parameter intermediary + real(r8) :: m2 ! parameter intermediary + real(r8) :: satfrac ! saturation fraction + real(r8) :: dsatfrac_dth ! deriv satfrac wrt theta + real(r8) :: dpsidth ! change in matric potential WRT VWC + real(r8) :: th_interp ! vwc where we start interpolation range + + a1 = 1._r8/this%alpha + m1 = 1._r8/this%psd + m2 = 1._r8/(m1-1._r8) + + th_interp = max_sf_interp * (this%th_sat-this%th_res) + this%th_res + + ! Since we apply linear interpolation beyond the max and min saturated fractions + ! we just cap satfrac at those values and calculate the derivative there + !! satfrac = max(min(max_sf_interp,(th-this%th_res)/(this%th_sat-this%th_res)),min_sf_interp) + + if(th>th_interp) then + satfrac = max_sf_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 + ! psi = -a1 * (satfrac**m2 - 1)** m1 + ! dpsi dth = -(m1)*a1*(satfrac**m2-1)**(m1-1) * m2*(satfrac)**(m2-1)*dsatfracdth + + ! f(x) = satfrac**m2 -1 + ! g(x) = a1*f(x)**m1 + ! dpsidth = g'(f(x)) f'(x) + + dpsidth = -m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) * m2*satfrac**(m2-1._r8)*dsatfrac_dth + + + end function dpsidth_from_th_vg + + ! ===================================================================================== + + function ftc_from_psi_vg(this,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 + real(r8) :: psi_eff + real(r8) :: m ! inverse pore size distribution param (1/psd) + + m = 1._r8/this%psd + + if(psi<0._r8) then + + ! 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-m)))**2._r8 + den = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*(1._r8-m)) + + ! 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 + + ! ==================================================================================== + + 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, 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) :: 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 + real(r8) :: m ! pore size distribution param (1/psd) + + m = 1._r8/this%psd + + if(psi>=0._r8) then + dftcdpsi = 0._r8 + else + psi_eff = -psi ! switch VG 1980 convention + + ftc = this%ftc_from_psi(psi) + + 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)**(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-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 - & + t3**(-2._r8)*dt3*(1._r8-t1*t2)**2._r8 + end if + + end if + + 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 + real(r8), intent(in) :: params_in(:) + real(r8) :: th_max + + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) + + ! Set DERIVED constants + ! used for interpolating in extreme ranges + 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) + + return + end subroutine set_wrf_param_cch + + ! ===================================================================================== + + subroutine set_wkf_param_cch(this,params_in) + + class(wkf_type_cch) :: this + real(r8), intent(in) :: params_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(this,psi) result(th) + + class(wrf_type_cch) :: this + real(r8), intent(in) :: psi + real(r8) :: th + real(r8) :: satfrac + + if(psi>this%psi_max) then + ! Linear range for extreme values + 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 + 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) :: satfrac + + 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 + + end function psi_from_th_cch + + ! ===================================================================================== + + function dpsidth_from_th_cch(this,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(this,psi) result(ftc) + + class(wkf_type_cch) :: this + 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 + + ! 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(psithis%psi_max) then + + ! Linear range for extreme values + th = this%th_res+max_sf_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 + + ! locals + real(r8) :: th_corr ! corrected vol wc [m3/m3] + real(r8) :: psi_sol ! pressure from solute term + real(r8) :: psi_press ! pressure from "pressure term" + 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 + real(r8) :: satfrac ! saturated fraction (between res and sat) + + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + + if(satfrac>max_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_sf_interp) then + + dpsidth = this%dpsidth_max + + elseif(satfrac0._r8)then + dftcdpsi = 0._r8 + else + ftc = 1._r8/(1._r8 + (psi/this%p50)**this%avuln) + if(ftc 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 15f061e643..ca984d16da 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1,201 +1,281 @@ 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 FatesAllometryMod , only : set_root_fraction - use FatesAllometryMod , only : i_hydro_rootprof_context - 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 + ! ============================================================================================== + ! 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 + ! + ! ============================================================================================== + + 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 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 FatesConstantsMod, only : fates_unset_r8 + + 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 + use EDTypesMod , only : AREA_INV + use EDTypesMod , only : AREA + use EDTypesMod , only : leaves_on + + 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 + 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 + use FatesHydraulicsMemMod, only: n_hypool_plant + use FatesHydraulicsMemMod, only: n_hypool_leaf + use FatesHydraulicsMemMod, only: n_hypool_tot + use FatesHydraulicsMemMod, only: n_hypool_stem + use FatesHydraulicsMemMod, only: n_hypool_troot + use FatesHydraulicsMemMod, only: n_hypool_aroot + use FatesHydraulicsMemMod, only: n_plant_media + use FatesHydraulicsMemMod, only: nshell + use FatesHydraulicsMemMod, only: n_hypool_ag + use FatesHydraulicsMemMod, only: stomata_p_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: nlevsoi_hyd_max + 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 + use PRTGenericMod, only : store_organ, repro_organ, struct_organ - use EDPftvarcon, only : EDPftvarcon_inst + use clm_time_manager , only : get_step_size, get_nstep - ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - use shr_infnan_mod , only : isnan => shr_infnan_isnan + use EDPftvarcon, only : EDPftvarcon_inst + 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 - 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__ + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan - - ! 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 - !------------------------------------------------------------------------------ - -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 - - ! ===================================================================================== + 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) + + integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran + ! 1 => 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 + ! 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)? + + ! 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 + ! 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 :: 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. + + + + 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 = .false. ! flag to report warning in hydro + + + character(len=*), parameter, private :: sourcefile = & + __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) + real(r8), parameter :: max_wb_step_err = 1.e-7_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 :: UpdateSizeDepPlantHydProps + public :: UpdateSizeDepPlantHydStates + public :: UpdatePlantPsiFTCFromTheta + public :: InitPlantHydStates + public :: UpdateSizeDepRhizHydProps + public :: UpdateSizeDepRhizHydStates + public :: RestartHydrStates + public :: SavePreviousCompartmentVolumes + public :: SavePreviousRhizVolumes + public :: UpdatePlantHydrNodes + public :: UpdatePlantHydrLenVol + public :: UpdatePlantKmax + public :: ConstrainRecruitNumber + public :: InitHydroGlobals + + !------------------------------------------------------------------------------ + ! 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 RestartHydrStates(sites,nsites,bc_in,bc_out) ! It is assumed that the following state variables have been read in by ! the restart machinery. @@ -217,59 +297,115 @@ 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 - type(ed_patch_type),pointer :: cpatch ! current patch - type(ed_cohort_type),pointer :: ccohort ! current cohort - type(ed_cohort_hydr_type),pointer :: ccohort_hydr - integer :: s ! site loop counter + 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 + 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)) - - ! This calculates volumes, lengths and max conductances - call UpdateTreeHydrLenVolCond(ccohort,sites(s)%si_hydr%nlevsoi_hyd,bc_in(s)) - + call UpdatePlantHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & + sites(s)%si_hydr) + + ! This calculates volumes and lengths + call UpdatePlantHydrLenVol(ccohort,csite_hydr) + + ! This updates the Kmax's of the plant's compartments + 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. 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 - + cpatch => cpatch%younger end do + + 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 + ! 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%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_bc), th_res_vg]) + end do + case(campbell_type) + 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_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' + 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%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%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_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 - 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 + ! Update static quantities related to the rhizosphere @@ -279,22 +415,21 @@ 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 - + call UpdateH2OVeg(nsites,sites,bc_out) return - end subroutine RestartHydrStates - - ! ==================================================================================== + end subroutine RestartHydrStates + + ! ==================================================================================== + + subroutine InitPlantHydStates(site, cohort) - 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 @@ -304,215 +439,279 @@ 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 ! ! !LOCAL VARIABLES: - 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 - real(r8) :: dz - real(r8) :: smp - - cCohort => cc_p - ccohort_hydr => cCohort%co_hydr - csite => site_p - 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 - !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) = 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 ) - end do + type(ed_site_hydr_type), pointer :: site_hydr + type(ed_cohort_hydr_type), pointer :: cohort_hydr + 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] - !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. - 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 - 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 + ! 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 - !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 - 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 - 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 + ! Set abosrbing root + + if(init_mode == 2) then + +! h_aroot_mean = 0._r8 + + 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*(-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 + + else + + 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)) + 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 - 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_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 + !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) + 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 + ! 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 + + + ! Set the transporting root to be in equilibrium with mean potential + ! of the absorbing roots, minus any gradient we add + + cohort_hydr%psi_troot = h_aroot_mean - & + mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz + + 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) + + + ! 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 + + + 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 = 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 + + 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 - call flc_gs_from_psi(cCohort, ccohort_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) + + ! 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_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 + - end subroutine initTreeHydStates + end subroutine InitPlantHydStates ! ===================================================================================== + subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) - 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 + ! 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 + + - - ! 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 + ccohort_hydr => ccohort%co_hydr + ft = ccohort%pft + + ! Update Psi and FTC in above-ground compartments + ! ----------------------------------------------------------------------------------- + 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 - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) + 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 - 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) - + ! Update the Psi and FTC for the transporting root compartment + 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%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 + + return + end subroutine UpdatePlantPsiFTCFromTheta - ! 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 UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) + + ! -------------------------------------------------------------------------------- + ! 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_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] + 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] + 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) + nlevrhiz = csite_hydr%nlevrhiz + 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 Node depth [m] (negative from surface) + + 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(csite_hydr%zi_rhiz(nlevrhiz))) + ccohort_hydr%z_node_troot = -z_cumul_rf + + return + end subroutine UpdatePlantHydrNodes + + ! ===================================================================================== + 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_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) + + subroutine UpdateSizeDepPlantHydProps(currentSite,ccohort,bc_in) ! DESCRIPTION: Updates absorbing root length (total and its vertical distribution) @@ -528,419 +727,223 @@ 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 ! 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) - + 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 UpdateTreeHydrLenVolCond(ccohort,nlevsoi_hyd,bc_in) - - end subroutine updateSizeDepTreeHydProps - - ! ===================================================================================== - - subroutine updateWaterDepTreeHydProps(currentSite,ccohort,bc_in) + ! 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) - ! 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 + end subroutine UpdateSizeDepPlantHydProps - ! 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 + subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) - nlevsoi_hyd = currentSite%si_hydr%nlevsoi_hyd - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft + ! ----------------------------------------------------------------------------------- + ! This subroutine calculates two attributes of a plant: + ! 1) the volumes of storage compartments in the plants + ! 2) the lenghts of the organs + ! 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. + ! + ! Inputs, plant geometries, plant carbon pools, z_node values + ! + ! ----------------------------------------------------------------------------------- + + ! Arguments + type(ed_cohort_type),intent(inout) :: ccohort + type(ed_site_hydr_type),intent(in) :: site_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. + 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) :: 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] + 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] + 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] + 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) :: 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 + + 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 - call UpdateWaterDepTreeHydrCond(currentSite,ccohort,nlevsoi_hyd,bc_in) + 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) + struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) + + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) + + ! Leaf Volumes + ! ----------------------------------------------------------------------------------- + + ! 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 - end subroutine updateWaterDepTreeHydProps - - ! ===================================================================================== + ! empirical regression data from leaves at Caxiuana (~ 8 spp) + denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 + + ! Leaf volumes + ! 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. - 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), allocatable :: rootfrs(:) ! Vector of root fractions (only used in 1 layer case) [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 - + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] - ! ------------------------------------------------------------------------------ - ! 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 + ! Get the target, or rather, maximum leaf carrying capacity of plant + ! Lets also avoid super-low targets that have very low trimming functions - 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 + call bleaf(ccohort%dbh,ccohort%pft,max(ccohort%canopy_trim,min_trim),leaf_c_target) - !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 ) + 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 + ! ----------------------------------------------------------------------------------- - ! 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 + ! 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 ) - 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 + ! calculate the sapwood cross-sectional area + 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 - ! 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) + ! alternative cross section calculation + ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - !! BOC not sure if/how we should multiply this by the sapwood fraction - ccohort_hydr%v_troot(:) = v_troot / n_hypool_troot + call CrownDepth(ccohort%hite,crown_depth) + z_stem = ccohort%hite - crown_depth + 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 - - ! 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 + ! 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 - - ! 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 - allocate(rootfrs(bc_in%nlevsoil)) - call set_root_fraction(rootfrs(:), ft, bc_in%zi_sisl, & - icontext = i_hydro_rootprof_context) - - ccohort_hydr%kmax_treebg_layer(:) = ccohort_hydr%kmax_treebg_tot * rootfrs(:) - deallocate(rootfrs) - 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 + woody_bg_c = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) + v_troot = woody_bg_c * EDPftvarcon_inst%c2b(ft) / & + (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) - !===================================================================================== - - subroutine UpdateWaterDepTreeHydrCond(currentSite,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*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) - ! ----------------------------------------------------------------------------------- - ! 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 - ! MAYBE ADD A NAN CATCH? If updateSizeDepTreeHydProps() was not called twice prior to the first + associate(pm_node => currentSite%si_hydr%pm_node) + + ! 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) - ! 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 + th_ag_uncorr(k) = ccohort_hydr%th_ag(k) + 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, 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) + 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)) enddo - do j=1,currentSite%si_hydr%nlevsoi_hyd + + 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, pm_node(3)) + + + ccohort_hydr%errh2o_growturn_aroot = 0._r8 + 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, 4) - ccohort_hydr%errh2o_growturn_aroot(j) = ccohort_hydr%th_aroot(j) - th_aroot_uncorr(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)) + 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(:) = 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_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%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 - + end associate - end subroutine updateSizeDepTreeHydStates + end subroutine UpdateSizeDepPlantHydStates -! ===================================================================================== - - 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) @@ -1014,8 +1037,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,pm_type) + thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) th_corr = max((thr+delta),min((ths-delta),th_uncorr)) return @@ -1023,237 +1046,165 @@ 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 + subroutine CopyCohortHydraulics(newCohort, oldCohort) - !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 + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort - 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 + ! 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 + + ! 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_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 + + ! 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%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 + 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 + ncohort_hydr%errh2o_pheno_aroot = ocohort_hydr%errh2o_pheno_aroot + + ! BC PLANT HYDRAULICS - flux terms + ncohort_hydr%qtop = ocohort_hydr%qtop + + ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited - 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 + 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 + integer :: ft - ncohort_hydr%errh2o_pheno_ag = ocohort_hydr%errh2o_pheno_ag + 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 + + ! 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 + 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 - 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 + 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 - end subroutine CopyCohortHydraulics - - ! ===================================================================================== - subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) + 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) - - 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(:) + 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 + + + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + + ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & + nextCohort%n*ncohort_hydr%qtop)/newn - ccohort_hydr%is_newly_recruited = .false. + 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%is_newly_recruited = .false. end subroutine FuseCohortHydraulics ! ===================================================================================== ! Initialization Routines ! ===================================================================================== - + subroutine InitHydrCohort(currentSite,currentCohort) ! Arguments @@ -1264,10 +1215,10 @@ 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. - + end subroutine InitHydrCohort ! ===================================================================================== @@ -1278,7 +1229,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) @@ -1288,407 +1239,432 @@ 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 + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - ! Locals - integer :: nsites - integer :: s - type(ed_site_hydr_type),pointer :: csite_hydr - + ! Locals + integer :: nsites + integer :: s + integer :: j + integer :: jj + type(ed_site_hydr_type),pointer :: csite_hydr - if ( hlm_use_planthydro.eq.ifalse ) return - - ! Initialize any derived hydraulics parameters - call InitHydraulicsDerived(numpft) + + + if ( hlm_use_planthydro.eq.ifalse ) return + + ! Initialize any derived hydraulics parameters + + 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 + + ! 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 - 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() + 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 - end subroutine InitHydrSites + 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 + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - if ( nlevsoil_hyd == 1) then + ! 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,j_bc + integer :: nsites + integer :: nlevrhiz + 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 - 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)) + nsites = ubound(sites,1) + + do s = 1,nsites + + 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%nlevrhiz) = 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%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,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_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' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j) + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wkf_type) + case(van_genuchten_type) + 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 - end if + 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 - 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) + end do - 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 + ! + !! call UpdateH2OVeg(nsites,sites,bc_out) + + ! -------------------------------------------------------------------------------- + ! All other ed_Hydr_site_type variables are initialized elsewhere: + ! + ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() + ! this%v_shell + ! this%r_node_shell + ! this%r_out_shell + ! + ! init_patch() -> UpdateSizeDepRhizHydProps() + ! this%l_aroot_layer_init + ! this%l_aroot_1D + ! this%kmax_upper_shell + ! this%kmax_lower_shell + ! + ! 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. + ! ---------------------------------------------------------------------------------- + + ! 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 + (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 + endif + + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop - ! 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 + 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 + ! 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 - 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 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. + ! 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 + 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) + real(r8) :: sum_l_aroot !sum of absorbing root lenghts + 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 - 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)) - 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 + 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 + recruitw_total = recruitw_total + recruitw + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + 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 + end do + 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%nlevrhiz + 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 + !===================================================================================== 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 + ! --------------------------------------------------------------------------- + + ! 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 [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 + 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) :: sum_l_aroot + 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(:)) + & + 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%nlevrhiz + cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + end do + + 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,:)) + 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) + + end do + + nmin = 1.0e+36 + 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) endif - end do - ccohort%n = min (ccohort%n, nmin) + end do + ccohort%n = min (ccohort%n, nmin) 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(:,:) - + return end subroutine SavePreviousRhizVolumes - + ! ====================================================================================== subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) @@ -1700,8 +1676,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! the same. ! ! !USES: - use EDTypesMod , only : AREA - + + ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in @@ -1715,16 +1691,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 - + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 + 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 @@ -1739,57 +1716,72 @@ 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 + 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), & - csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) - end if !has l_aroot_layer 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, 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 - 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 - !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 + + 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) + ! + ! 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_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 - 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 - enddo ! loop over rhizosphere shells + ! 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 + + 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 - return 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 @@ -1798,8 +1790,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 @@ -1807,21 +1797,21 @@ 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 - + call UpdateSizeDepRhizVolLenCon(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 @@ -1838,7 +1828,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] @@ -1850,11 +1840,12 @@ 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 !----------------------------------------------------------------------- - + s_shell_init(:,:) = 0._r8 psi_shell_init(:,:) = 0._r8 psi_shell_interp(:,:) = 0._r8 @@ -1863,228 +1854,197 @@ 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 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 + 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)) + psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(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 - ! 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)) + 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%nlevrhiz + ! 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)) + 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%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)) / & + (bc_in%watres_sisl(j_bc)+bc_in%watres_sisl(j_bc)) - 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%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 + 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 * & + (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)-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 - 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%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)) / & + (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%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 - 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)-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 + enddo + h2osoi_liq_col_new(j) = w_layer_new(j)/ v_rhiz(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 + ! balance check + 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 ',& - ' local indexj= ',indexj,& - ' errh2o= ',errh2o(indexj) + ' updating rhizosphere shells: ',j,errh2o(j) + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - enddo - end if !nshell > 1 - - end subroutine updateSizeDepRhizHydStates + 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) + + ! 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 * & + (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) ! @@ -2107,7 +2067,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 @@ -2116,22 +2075,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 :: 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 @@ -2147,16 +2107,13 @@ 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 - - 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 + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + 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 @@ -2165,7 +2122,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) 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) @@ -2190,10 +2147,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)) - 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 + 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 @@ -2206,8 +2162,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 @@ -2216,3129 +2171,3197 @@ 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) - - 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 - sum( bc_in(s)%h2o_liq_sisl(:) ) - end if - + + 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 + 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 - - ! 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 + 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 - 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 + ! + ! !DESCRIPTION: + !s + ! !USES: + 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 - 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 + ! + ! !LOCAL VARIABLES: + 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 :: sz ! plant's size class index + integer :: t ! previous timesteps (for lwp stability calculation) + integer :: nstep !number of time steps - ! 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 + 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 + + ! Local arrays - ! 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 + ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) + ! array of soil layer indices which have been ordered + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) - if(site_hydr%nlevsoi_hyd == 1) then - bc_out(s)%qflx_soil2root_sisl(1:bc_in(s)%nlevsoil-1) = 0._r8 + ! 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] + 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) :: 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] + 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 + + ! ---------------------------------------------------------------------------------- + ! 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. + ! ---------------------------------------------------------------------------------- - ! qflx_rootsoi(c,bc_in(s)%nlevsoil) = - ! -(sum(dth_layershell_col(j,:))*bc_in(s)%dz_sisl(j)*denh2o/dtime) + !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake + call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - 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) + !update water storage in veg after incorporating newly recuited cohorts + if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) -! 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) + 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 + 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 + + ! 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] + ! -------------------------------------------------------------------------------- + transp_flux = 0._r8 + root_flux = 0._r8 + + ! Initialize the delta in soil water and plant water storage + ! with the initial condition. + + !err_soil = delta_soil_storage - root_flux + !err_plot = delta_plant_storage - (root_flux - transp_flux) + + 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 + + ! 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_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 + + transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV + + ! 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 | + !--------------------------------------------------------------------------- + + + ! This routine will update the theta values for 1 cohort's flow-path + ! from leaf to the current soil layer. This does NOT + ! update cohort%th_* + + if(use_2d_hydrosolve) then + + call MatSolve2D(site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col) 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)) + + ! --------------------------------------------------------------------------------- + ! 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 + ! ----------------------------------------------------------------------------------- - ! 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) + call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) + + call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & + sapflow,rootuptake(1:nlevrhiz), & + wb_err_plant,dwat_plant, & + dth_layershell_col) + + end if - end if + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - 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 + ! Update total error in [kg/m2 ground] + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - - enddo !site - - end subroutine Hydraulics_BC + ! 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 - ! ===================================================================================== + sc = ccohort%size_class + + ! Sapflow diagnostic [kg/ha/s] + 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/dtime - subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_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) - ! --------------------------------------------------------------------------- - ! 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 + 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/dtime - ! 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 + 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/dtime - !-------------------------------------------------------------------------------! - - subroutine RecruitWaterStorage(nsites,sites,bc_out) + 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/dtime - ! --------------------------------------------------------------------------- - ! 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 + 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/dtime + + ! --------------------------------------------------------- + ! Update water potential and frac total conductivity + ! of plant compartments + ! --------------------------------------------------------- + + call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) - end do - - return - end subroutine RecruitWaterStorage + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + - - !-------------------------------------------------------------------------------! - - subroutine Hydraulics_1DSolve(cc_p, 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) - - use EDTypesMod , only : AREA - ! - ! !DESCRIPTION: - ! - ! - ! !ARGUMENTS - type(ed_cohort_type) , intent(inout), target :: cc_p ! 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(inout) :: th_node(:) ! volumetric water in water storage compartments [m3 m-3] - 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(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 - real(r8) , intent(out) :: dqtopdth_dthdt - real(r8) , intent(out) :: sapflow - real(r8) , intent(out) :: rootuptake - 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 - 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 + ccohort => ccohort%shorter + enddo !cohort + + cpatch => cpatch%younger + 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%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - ! - ! !LOCAL VARIABLES: - type(ed_cohort_type) , pointer :: ccohort ! - 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 - real(r8) :: w_tot_end_outer - 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_fac2 ! 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-1] - 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 - 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 - !---------------------------------------------------------------------- - - ccohort => cc_p - 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(:) - - ! WATER BALANCE - 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 - - !! 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 - 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 + do j=1,site_hydr%nlevrhiz + j_bc = j+site_hydr%i_rhiz_t-1 - !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) - - ! 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 - - 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 - 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 - 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(:) + ! 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 subroutine Hydraulics_1DSolve - !-------------------------------------------------------------------------------! - subroutine Hydraulics_Tridiagonal(a, b, c, r, u) - ! - ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 - ! - ! !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 - !---------------------------------------------------------------------- + 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) + + + ! 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_bc) - & + dtime*bc_out(s)%qflx_soil2root_sisl(j_bc) + + + ! 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 + + 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_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_bc)-thsat_buff)) * & + site_hydr%v_shell(j,i)*AREA_INV*denh2o + + 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_bc) = site_runoff/dtime + end if + enddo - 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 + + ! 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(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil + + 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 + 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 (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]' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - enddo - - do k=n_hypool_tot-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) - enddo - - 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) - ! - ! !ARGUMENTS - integer , intent(in) :: k_arootsoil ! index of node where the boundary occurs between root and soil - real(r8) , intent(in) :: z_node(:) ! height of node [m] - real(r8) , intent(in) :: psi_node(:) ! water potential in water storage compartments [MPa] - 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(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) :: 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] - real(r8), optional, intent(in) :: kmax_bound_aroot_soil1 ! maximum radial conductance of absorbing roots [kg s-1 MPa-1] - real(r8), optional, intent(in) :: kmax_bound_aroot_soil2 ! maximum conductance to root surface from innermost rhiz shell [kg s-1 MPa-1] - ! - ! !LOCAL VARIABLES: - integer :: k ! shell 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 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)) - if(do_kbound_upstream) then + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks - ! 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) + ! 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 - 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: ',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 + write(fates_log(),*) 'site_runoff: ',site_runoff + write(fates_log(),*) 'transp_flux: ',transp_flux 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 boundary_hdiff_and_k - - !-------------------------------------------------------------------------------! - subroutine flc_gs_from_psi(cc_p, lwp ) - ! - ! !DESCRIPTION: - ! - ! !USES: + + ! 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(),*) '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 + write(fates_log(),*) 'transp_flux: ',transp_flux + end if + + + 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 - & + site_hydr%h2oveg_pheno_err-& + site_hydr%h2oveg_hydro_err + + enddo !site + + return + end subroutine Hydraulics_BC + + ! ===================================================================================== + + + + subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) + + ! --------------------------------------------------------------------------------- ! - ! !ARGUMENTS - type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer - real(r8) , intent(in) :: lwp !leaf water potential (MPa) + ! 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] ! - ! !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 + ! 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. ! - ! !USES: + ! 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. ! - ! !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 [-] + ! 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). + ! --------------------------------------------------------------------------------- - !---------------------------------------------------------------------- - - 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 + ! Arguments - 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 + 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 - ! - ! !LOCAL VARIABLES: + ! 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 + ! 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 + 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 + 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) + + ! 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 = 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 + ! 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 + ! 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 + + ! 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) = (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) = (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) ) 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 - !---------------------------------------------------------------------- - - 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 = ', iswc - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - 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 + 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) + + !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 + ! 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/ccohort_hydr%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 + ! (rmin_ag+rmin_bg)*fr = rmin_ag + ! rmin_ag + rmin_bg = rmin_ag/fr + ! rmin_bg = (1/fr-1) * rmin_ag ! - ! !USES: + ! if kmax_bg = 1/rmin_bg : ! - ! !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 + ! kmax_bg = 1/((1/fr-1) * rmin_ag) + + kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) + - ! - ! !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] - ) + ! 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%nlevrhiz + + 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. + ! 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) = 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 + + ! 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,csite_hydr%nlevrhiz + + ! Surface area of the absorbing roots for a single plant in this layer [m2] + 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 + + ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + + end do + + return + end subroutine UpdatePlantKmax + + ! =================================================================================== + + subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) - 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 = ', iswc - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate + ! 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 - 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 + ! Arguments (INOUT) + integer, intent(inout) :: ordered(:) + real(r8), intent(out) :: kbg_layer(:) + + ! Locals + + 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 + 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 :: ft ! functional type index of plant + integer :: j,jj,k ! layer and shell indices + + + kbg_tot = 0._r8 + kbg_layer(:) = 0._r8 - 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 ) + ft = cohort%pft + + do j=1,site_hydr%nlevrhiz - if(psi_check > -1.e-8_r8) then - write(fates_log(),*)'bisect_pv returned positive value for water potential at pm = ', pm - call endrun(msg=errMsg(sourcefile, __LINE__)) + ! 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(cohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) + else + 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(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(cohort_hydr%psi_aroot(j)) - 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 = ', iswc - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - end if - - end associate + ! 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 = cohort_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(k 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 + 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%nlevrhiz-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 + - 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] - !---------------------------------------------------------------------- + return + end subroutine OrderLayersForSolve1D - if(pm <= 4) then ! plant + ! ================================================================================= - call tq2(ft, pm, th_node*cap_corr(pm), psi_node) + subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & + ordered,kbg_layer, sapflow,rootuptake,& + wb_err_plant,dwat_plant,dth_layershell_col) + + ! ------------------------------------------------------------------------------- + ! 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) + type(ed_cohort_type),intent(in),target :: cohort + type(ed_cohort_hydr_type),intent(inout),target :: cohort_hydr + type(ed_site_hydr_type), intent(in),target :: site_hydr + 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) :: 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]) - else if(pm == 5) then ! soil + ! Locals + integer :: i ! node index "i" + integer :: j ! path index "j" + 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 + integer :: ishell ! rhizosphere shell index of the node + 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 + 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] + real(r8) :: rootfr_scaler ! Factor to scale down cross-section areas based on what + ! fraction of root is in current layer [-] + 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] + 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) :: 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] + -!! 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 = ', iswc - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + 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] + real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] + 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] + 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] + 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) :: 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 + real(r8) :: tris_r(n_hypool_tot) ! off (constant coefficients) matrix terms + real(r8) :: sum_l_aroot ! + 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 + 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) + ! 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 + integer, parameter :: max_iter = 20 ! Maximum number of iterations with which we reduce timestep + + real(r8), parameter :: max_wb_err = 1.e-5_r8 ! threshold for water balance error (stop model) [kg h2o] - 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 = ', 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) + logical, parameter :: no_ftc_radialk = .false. + 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 - 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) + 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) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 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 + + ft = cohort%pft + + ! Total length of roots per plant for this cohort + sum_l_aroot = sum(cohort_hydr%l_aroot_layer(:)) + + ! ----------------------------------------------------------------------------------- + ! 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 + ! ----------------------------------------------------------------------------------- + + do jj=1,site_hydr%nlevrhiz + + 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%nlevrhiz,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 + + ! 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 + rootfr_scaler = cohort_hydr%l_aroot_layer(ilayer)/sum_l_aroot + 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) = -site_hydr%zi_rhiz(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) = -site_hydr%zi_rhiz(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 ) + + ! Gracefully quit if too many iterations have been used + if(iter>max_iter)then + 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) + + 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 + + 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(:) + + ! 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 i = 1,n_hypool_plant + + ! Get matric potential [Mpa] + 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(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + + ! deriv psi wrt theta + 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(pm_node(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(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 + + 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 = 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)) + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do j=2,n_hypool_ag-1 + + i_up = j+1 + i_dn = j + + ! "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_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_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 + + + ! Path is between lowest stem and transporting root + + 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+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+1 + i_dn = j + + ! Special case. Maximum conductance depends on the + ! potential gradient. + 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_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) + end if + + kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_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_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+1 + i_dn = j + ishell_up = i_up - (n_hypool_tot-nshell) + ishell_dn = i_dn - (n_hypool_tot-nshell) + + 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_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 + + ! ------------------------------------------------------------------------------- + ! 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 + + 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 + + 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 + ! 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 .or. any(dth_node(:).ne.dth_node(:)) )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(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)) + end do + + ! 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_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 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + i = n_hypool_ag+2 + 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 + + ! 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 + + ! ----------------------------------------------------------- + ! 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(:) + + + ! Add the current soil layer's contribution to total + ! sap and root flux [kg] + sapflow = sapflow + sapflow_lyr + rootuptake(ilayer) = rootuptake_lyr + + + ! 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)>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) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter)) + ! Save the number of sub-steps we ultimately used + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps)) + + ! Update water contents in the relevant plant compartments [m3/m3] + ! ------------------------------------------------------------------------------- + + ! Leaf and above-ground stems + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + ! Transporting root + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + ! Absorbing root + cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) + + ! Change in water per plant [kg/plant] + 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 + + ! Remember the error for the cohort + 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 + ! 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) + + end associate + return + end subroutine ImTaylorSolve1D + + ! ===================================================================================== + + 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) + + ! 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 + 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 :: i + integer :: ft + real(r8) :: leaf_water + real(r8) :: stem_water + real(r8) :: troot_water + real(r8) :: aroot_water + real(r8), allocatable :: psi_node(:) + real(r8), allocatable :: h_node(:) + + cohort_hydr => 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(),*) '' + write(fates_log(),*) 'error code: ',err_code + write(fates_log(),*) 'error diag: ',err_arr(:) + + 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 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 + + + 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(),*) '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),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),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)) + 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) + 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' + 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) + + + ! Most likely you will want to end-run after this routine, but maybe not... + + return + end subroutine Report1DError + + ! ================================================================================= + + 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 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_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_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 - 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 + ! 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 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 + + + + return + end subroutine GetImTaylorKAB + + ! ===================================================================================== + + subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & + h_dn,h_up, & + ftc_dn,ftc_up, & + dftc_dpsi_dn, & + dftc_dpsi_up, & + dk_dpsi_dn, & + dk_dpsi_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_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] + ! 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_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_dpsi_dn = 0._r8 + else + 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_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 + end subroutine GetKAndDKDPsi + + 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. + ! --------------------------------------------------------------------------- + + ! 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(:)) + & + 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 + + + csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w + + return + end subroutine AccumulateMortalityWaterStorage + !-------------------------------------------------------------------------------! - 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] + + 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. + ! --------------------------------------------------------------------------- + + ! 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(:)) + & + 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_INV + + end do + + return + end subroutine RecruitWaterStorage + + ! ===================================================================================== + + ! ===================================================================================== + ! Utility Functions + ! ===================================================================================== + + subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) ! - ! !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 + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). ! ! !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] + 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) :: dsoldth ! returned derivative from dsolutepsidth() - real(r8) :: dpressdth ! returned derivative from dpressurepsidth() + 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) !---------------------------------------------------------------------- - - 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: + + 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) ! - ! !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] + real(r8) :: crootfr_max + + ! !RESULT + real(r8) :: crootfr ! cumulative root fraction ! - ! !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 + !------------------------------------------------------------------------ + 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 subroutine solutepsi - - !-------------------------------------------------------------------------------! - subroutine dsolutepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of solutepsi() wrt theta + 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 - 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] + ! !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: - !---------------------------------------------------------------------- - - 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 [-] - ) + integer :: k ! rhizosphere shell indicies + integer :: nshells ! We don't use the global because of unit testing + !----------------------------------------------------------------------- + + + nshells = size(r_out_shell,dim=1) - 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 + ! 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 dsolutepsidth - - !-------------------------------------------------------------------------------! - subroutine pressurepsi(ft, pm, x, y) - ! - ! !DESCRIPTION: computes pressure water potential (positive) as a function of - ! water content for the plant PV curve. + return + 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] ! - ! !USES: + ! !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 ! - ! !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] + ! !RESULT + real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz ! - ! !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 + !------------------------------------------------------------------------ + + 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 subroutine pressurepsi + end function xylemtaper - !-------------------------------------------------------------------------------! - subroutine dpressurepsidth(ft, pm, x, y) - ! - ! !DESCRIPTION: returns derivative of pressurepsi() wrt theta + ! ===================================================================================== + + subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) ! - ! !USES: + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 ! - ! !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] + ! This solves the form: ! - ! !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) + ! 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 - 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] + 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 + integer, intent(out) :: ierr ! flag: 0=passed, 1=failed ! ! !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 + !---------------------------------------------------------------------- + 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 - 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 + do k=N-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) + enddo - 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: - !---------------------------------------------------------------------- + ! 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) .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 + write(fates_log(),*) 'Reducing time-step' + ierr = 1 + end if + end if + end do + end if + + end subroutine Hydraulics_Tridiagonal - associate(& - thetas => EDPftvarcon_inst%hydr_thetas_node & ! Input: [real(r8) (:,:) ] P-V curve: saturated volumetric water content for node [m3 m-3] - ) + ! ===================================================================================== + + subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & + dth_layershell_site) + + + ! --------------------------------------------------------------------------------- + ! 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 + type(ed_cohort_hydr_type), target :: cohort_hydr + type(ed_cohort_type) , intent(inout), target :: cohort + 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] - y = cap_slp(pm)/thetas(ft,pm) - - end associate + + 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 + 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) :: 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) :: 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) :: 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 - 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) + real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments + real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - end subroutine swcVG_satfrac_from_th + 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 - !-------------------------------------------------------------------------------! - 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: - !------------------------------------------------------------------------------ + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + + integer :: info + integer :: nstep !number of time steps - satfrac = th/watsat - end subroutine swcCampbell_satfrac_from_th + ! 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] *Note, 1.e-9 = 1 ug/s + real(r8), parameter :: max_allowed_residual = 1.e-8_r8 - !-------------------------------------------------------------------------------! - 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] - !------------------------------------------------------------------------------ + ! 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 - call swcVG_satfrac_from_th(th, watsat, watres, satfrac) - call swcVG_psi_from_satfrac(satfrac, alpha, n, m, l, psi) + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.2_r8 + + 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 + nstep = get_nstep() + - end subroutine swcVG_psi_from_th + ! This NaN's the scratch arrays + call site_hydr%FlushSiteScratch() - !-------------------------------------------------------------------------------! - 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] - !------------------------------------------------------------------------------ + ! 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 - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_psi_from_satfrac(satfrac, psisat, B, psi) + ! 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 - end subroutine swcCampbell_psi_from_th + ! 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 + + 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 + i = n_hypool_ag + n_hypool_troot + + do j = 1,site_hydr%nlevrhiz - !-------------------------------------------------------------------------------! - 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: - !------------------------------------------------------------------------------ + ! 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 = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + + do k = 1, n_hypool_aroot + nshell + i = i + 1 + if (k==1) then + 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) = -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) + end if + enddo - psi = -1._r8/alpha*(satfrac**(-1._r8/m)-1._r8)**(1._r8/n) + enddo - end subroutine swcVG_psi_from_satfrac + + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - !-------------------------------------------------------------------------------! - 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: - !------------------------------------------------------------------------------ + + ! Initialize variables and flags that track + ! the progress of the solve - psi = psisat*(satfrac**(-B)) + tm = 0 + nsteps = 0 - end subroutine swcCampbell_psi_from_satfrac + outerloop: do while(tm < tmx) - !-------------------------------------------------------------------------------! - 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: - !------------------------------------------------------------------------------ + ! If we are here, then we either are starting the solve, + ! 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 = min(tmx*0.01,tmx-tm) + + ! Relaxation factors are reset to starting point. + 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 + ! because it couldn't get a zero residual, or because + ! a singularity was encountered. +100 continue + + ! Set the current water content as the initial [m3/m3] + th_node(:) = th_node_init(:) + + + tm = tm + dtime + nwtn_iter = 0 + + ! Return here if you are just continuing the + ! Newton search for a solution. No need to + ! update timing information. +200 continue + + nwtn_iter = nwtn_iter + 1 + + ! The Jacobian and the residual are incremented, + ! and the Jacobian is sparse, thus they both need + ! to be zerod. + ajac(:,:) = 0._r8 + residual(:) = 0._r8 + + + 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(pm_node(k) == rhiz_p_media) then + + 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 [-] + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - th = watres + satfrac*(watsat - watres) + else + + 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_plant(pm_node(k),ft)%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)) + + end if + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + if(pm_node(k) == rhiz_p_media) then + ajac(k,k) = denh2o*v_node(k)/ & + (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) + endif + + 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. + + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,site_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + ! 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 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) + + 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) - 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 = -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 = 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 + + ! 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 + + ! 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 + + + ! 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 + + ! 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 + do k = 1, site_hydr%num_nodes + rsdx = abs(residual(k)) + ! check NaNs + if( rsdx /= rsdx ) then + icnv = icnv_fail_round + exit + endif + if( rsdx > residual_amax ) then + residual_amax = rsdx + nsd = k + endif + enddo - end subroutine swcVG_th_from_satfrac + 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 - !-------------------------------------------------------------------------------! - 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: - !------------------------------------------------------------------------------ + goto 201 - th = satfrac*watsat + ! 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 - end subroutine swcCampbell_th_from_satfrac + icnv = icnv_fail_round + goto 199 - !----------------------------------------------------------------------- - 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 + ! 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 - end subroutine swcVG_satfrac_from_psi + ! 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 + + ! --------------------------------------------------------------------------- + ! From Lapack documentation + ! + ! 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. + ! 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. + ! --------------------------------------------------------------------------- + - !----------------------------------------------------------------------- - 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: - !------------------------------------------------------------------------------ + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - satfrac = (psi/psisat)**(-1.0_r8/B) + + 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 + 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, 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) + ! 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),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 + + endif + +199 continue + + 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, 'qtop: ',qtop + + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round + if( nsteps < max_newton_rounds ) then + + tm = tm - dtime + nsteps = nsteps + 1 + + 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' + + dtime = min(dtime * dtime_rf,tmx-tm) + + do k = 1,site_hydr%num_nodes + th_node(k) = th_node_init(k) + enddo + + ! 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 --- + ! + else + ! Complete failure to converge even with re-trying + ! iterations with smaller timestepps and relaxations + icnv = icnv_complete_fail + endif + + endif - 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] - !------------------------------------------------------------------------------ + + 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(:) = 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 + 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 - 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 + ! 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. - !----------------------------------------------------------------------- - 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] - !------------------------------------------------------------------------------ +201 continue - call swcCampbell_satfrac_from_th(th, watsat, satfrac) - call swcCampbell_dpsidth_from_satfrac(satfrac, watsat, psisat, B, dpsidth) + ! Save the number of substeps needed + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - end subroutine swcCampbell_dpsidth_from_th + ! Save the max number of Newton iterations needed + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nwtn_iter)) - !----------------------------------------------------------------------- - 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 - !------------------------------------------------------------------------------ + print*,'Completed a newton solve' + print*,psi_node(:) + stop - 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 + ! Save flux diagnostics + ! ------------------------------------------------------ - end subroutine swcVG_dpsidth_from_satfrac + sapflow = sapflow + q_flux(n_hypool_ag)*dtime - !----------------------------------------------------------------------- - 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] - !------------------------------------------------------------------------------ + 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(j) = q_flux(icnx_ar)*dtime + enddo - dpsidth = psisat*(-B)/watsat*(satfrac)**(-B-1._r8) - end subroutine swcCampbell_dpsidth_from_satfrac + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_init(:) = th_node(:) + + end do outerloop - !----------------------------------------------------------------------- - 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 + ! 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 - end subroutine unsatkVG_flc_from_psi + + ! 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 + + inode = n_hypool_ag+n_hypool_troot + do j = 1,site_hydr%nlevrhiz + do k = 1, nshell+1 + inode = inode + 1 + 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) - !----------------------------------------------------------------------- - 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 associate - end subroutine unsatkCampbell_flc_from_psi + return + end subroutine MatSolve2D - !----------------------------------------------------------------------- - 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 - !------------------------------------------------------------------------------ + ! ===================================================================================== + + 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 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 + 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 - ! 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 + end select - ! 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 + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- - end subroutine shellGeom + 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 + ! ----------------------------------------------------------------------------------- - function xylemtaper(p, dz) result(chi_tapnotap) + 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 - ! !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 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 function xylemtaper - end module FatesPlantHydraulicsMod diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 4e003474a3..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 @@ -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/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/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/HydroUTestDriver.py b/functional_unit_testing/hydro/HydroUTestDriver.py new file mode 100644 index 0000000000..c61aa8b7a2 --- /dev/null +++ b/functional_unit_testing/hydro/HydroUTestDriver.py @@ -0,0 +1,361 @@ +# ======================================================================================= +# +# 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, c8_arr, ci_arr + +# Load the fortran objects via CTYPES + +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) + +# Alias the F90 functions, specify the return type +# ----------------------------------------------------------------------------------- + +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_wrapdftcdpsi +dftcdpsi_from_psi.restype = c_double + + +# 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_troot = 3 +pm_aroot = 4 +pm_rhiz = 5 + +# These parameters are matched with the indices in FATES-HYDRO +vg_type = 1 +cch_type = 2 +tfs_type = 3 + +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 = True + + +# ======================================================================================== +# ======================================================================================== +# Main +# ======================================================================================== +# ======================================================================================== + + +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_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 + 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 + 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() + + + # Set number of analysis points + npts = 1000 + + + # min_theta = np.full(shape=(2),dtype=np.float64,fill_value=np.nan) + +# wrf_type = [vg_type, vg_type, cch_type, cch_type] +# wkf_type = [vg_type, tfs_type, cch_type, tfs_type] + +# 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= 3 + + 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 + iret = initalloc_wtfs(ci(ncomp),ci(ncomp)) + print('Allocated') + + + # 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(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) + + 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(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(3,p50=-2.25, avuln=2.0) + + 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) + + for ic in range(ncomp): + for i,th in enumerate(theta): + 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,:],label='{}'.format(names[ic])) + + 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): + 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]) + + + # 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') + ax1.plot(theta,cdpsidth[0,:],label='check') + ax1.set_ylim((0,1000)) + + ax1.set_ylabel('dPSI/dTh [MPa m3 m-3]') + ax1.set_xlabel('VWC [m3/m3]') + ax1.legend(loc='upper right') + + # Push parameters to WKF classes + # ------------------------------------------------------------------------- + # Generic VGs + + 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]) + + + # FTC versus Psi + + fig2, ax1 = plt.subplots(1,1,figsize=(9,6)) + for ic in range(ncomp): + ax1.plot(psi[ic,:],ftc[ic,:],label='{}'.format(names[ic])) + + ax1.set_ylabel('FTC') + ax1.set_xlabel('Psi [MPa]') + 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(names[ic])) + + 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.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())) + +# 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 + +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..75b6fe41f3 --- /dev/null +++ b/functional_unit_testing/hydro/build_hydro_f90_objects.sh @@ -0,0 +1,49 @@ +#!/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 + +# 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/FatesHydroWTFMod.o ../../biogeophys/FatesHydroWTFMod.F90 + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/HydroUnitWrapMod.o f90_src/HydroUnitWrapMod.F90 + + + + 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..03e95a6a32 --- /dev/null +++ b/functional_unit_testing/hydro/f90_src/HydroUnitWrapMod.F90 @@ -0,0 +1,171 @@ + +! 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 + use FatesHydroWTFMod, only : wrf_arr_type,wkf_arr_type,wrf_type_tfs + + implicit none + public + 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 + + + class(wrf_arr_type), public, pointer :: wrfs(:) ! This holds all (soil and plant) water retention functions + class(wkf_arr_type), public, pointer :: wkfs(:) ! + + +contains + + 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,npvals,pvals) + + ! The unit testing frameworks don't like assumed shape + ! array arguments + + integer,intent(in) :: index + integer,intent(in) :: itype + integer,intent(in) :: npvals + real(r8), intent(in) :: pvals(npvals) + + 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 + + if(itype == van_genuchten) then + allocate(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)%p => wrf_cch + call wrf_cch%set_wrf_param(pvals) !th_sat,psi_sat,beta + else + allocate(wrf_tfs) + wrfs(index)%p => wrf_tfs + call wrf_tfs%set_wrf_param(pvals) + end if + + return + end subroutine SetWRF + + subroutine SetWKF(index,itype,npvals,pvals) + + integer,intent(in) :: index + integer,intent(in) :: itype + 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)%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)%p => wkf_cch + call wkf_cch%set_wkf_param(pvals) !th_sat,psi_sat,beta + elseif(itype==tfs) then + allocate(wkf_tfs) + wkfs(index)%p => wkf_tfs + call wkf_tfs%set_wkf_param(pvals) !th_sat,p50,avuln + else + print*,"UNKNOWN WKF" + stop + end if + + return + end subroutine SetWKF + + + function WrapTHFromPSI(index,psi) result(th) + + integer, intent(in) :: index + real(r8),intent(in) :: psi + real(r8) :: th + + th = wrfs(index)%p%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)%p%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)%p%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 + + dftcdpsi = wkfs(index)%p%dftcdpsi_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 = wkfs(index)%p%ftc_from_psi(psi) + + return + end function WrapFTCFromPSI + + +end module HydroUnitWrapMod 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 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 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..347d3ed4e0 --- /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,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=='.' 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..49965e794c --- /dev/null +++ b/functional_unit_testing/shared/py_src/PyF90Utils.py @@ -0,0 +1,29 @@ +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 + +def c8(r8): + return(byref(c_double(r8))) + + +def ci(i8): + return(byref(c_int(i8))) + + +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))) + + +def ci_arr(int_list): + return(byref((len(int_list) * c_int)(*int_list))) 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 d820181c78..646084ef1b 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 @@ -35,14 +35,14 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_use_inventory_init - use FatesInterfaceMod , only : hlm_use_fixed_biogeog - 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 : hlm_use_fixed_biogeog + 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 @@ -84,6 +84,7 @@ module EDInitMod public :: set_site_properties private :: init_cohorts + ! ============================================================================ contains @@ -435,7 +436,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/EDMainMod.F90 b/main/EDMainMod.F90 index 1b520e56c3..0fbcb88b59 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 @@ -60,13 +60,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 @@ -256,12 +256,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) - ! if(nshell > 1) then (THIS BEING CHECKED INSIDE OF the update) - ! call updateSizeDepRhizHydStates(currentSite, c, soilstate_inst, & - ! waterstate_inst) - ! end if + call UpdateSizeDepRhizHydProps(currentSite, bc_in) + call UpdateSizeDepRhizHydStates(currentSite, bc_in) end if end if @@ -284,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: @@ -439,8 +435,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 ! if we are in age-dependent mortality mode @@ -727,7 +723,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 diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b4654f2c13..7b11df7cae 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2267,6 +2267,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. @@ -2694,7 +2696,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 fates_endrun use EDTypesMod , only : nclmax @@ -26,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 @@ -137,20 +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_nesterov_fire_danger_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_trimming_si + integer :: ih_area_plant_si + integer :: ih_area_trees_si integer :: ih_cwd_elcwd @@ -171,30 +161,31 @@ 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 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 @@ -216,7 +207,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 @@ -254,6 +244,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 @@ -265,6 +257,20 @@ module FatesHistoryInterfaceMod integer :: ih_dleafon_si integer :: ih_meanliqvol_si + integer :: ih_nesterov_fire_danger_si + integer :: ih_fire_intensity_area_product_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_area_product_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 @@ -324,7 +330,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 @@ -430,6 +435,10 @@ module FatesHistoryInterfaceMod integer :: ih_c_lblayer_si_age integer :: ih_agesince_anthrodist_si_age 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_sum_fuel_si_age ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height @@ -439,19 +448,10 @@ module FatesHistoryInterfaceMod integer :: ih_errh2o_scpf integer :: ih_tran_scpf - integer :: ih_rootuptake_scpf - 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_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 @@ -468,9 +468,29 @@ 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 + integer :: ih_burnt_frac_litter_si_fuel ! indices to (site x cwd size class) variables integer :: ih_cwd_ag_si_cwdsc @@ -1363,7 +1383,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 @@ -1546,7 +1566,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 @@ -1557,10 +1577,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 @@ -1572,7 +1594,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) @@ -1587,7 +1611,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 @@ -1661,9 +1686,7 @@ 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") real(r8) :: coage ! cohort age real(r8) :: npp_partition_error ! a check that the NPP partitions sum to carbon allocation @@ -1704,9 +1727,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, & @@ -1715,17 +1738,20 @@ 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_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_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_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_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, & + 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, & @@ -1738,16 +1764,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, & @@ -1804,6 +1830,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, & @@ -1891,6 +1918,11 @@ 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_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, & @@ -1945,9 +1977,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 @@ -1961,6 +1990,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 @@ -1989,6 +2024,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 @@ -2043,15 +2080,35 @@ 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 + 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)) @@ -2064,37 +2121,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 @@ -2142,16 +2170,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 @@ -2198,7 +2226,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 @@ -2360,7 +2388,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 + & @@ -2453,8 +2481,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 @@ -2578,31 +2606,35 @@ 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_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 - 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_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 + 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 * 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) + & 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 + + 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)) @@ -2987,7 +3019,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 @@ -2998,12 +3029,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, & @@ -3013,10 +3043,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, & @@ -3114,14 +3144,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 @@ -3129,21 +3152,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 @@ -3194,10 +3214,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) + & @@ -3215,10 +3235,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) + & @@ -3383,7 +3403,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 @@ -3391,6 +3411,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 @@ -3399,64 +3420,54 @@ 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 - real(r8) :: n_density ! individual of cohort per m2. - real(r8) :: n_perm2 ! individuals per m2 for the whole column +! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array 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" 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 :: j ! soil layer index + integer :: ipft ! index of the pft loop + integer :: iscls ! index of the size-class loop 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? - 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_h2osoi_shsl => this%hvars(ih_h2osoi_si_scagpft)%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, & @@ -3475,87 +3486,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 - - - ! 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 - - + + ! 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) + hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ccohort => cpatch%shortest @@ -3569,28 +3569,27 @@ 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) = 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 ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - io_pa = io_pa1 + ipa - ccohort => cpatch%shortest do while(associated(ccohort)) 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_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 - if ( .not. ccohort%isnew ) then ! Calculate index for the scpf class @@ -3606,103 +3605,60 @@ 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] - - hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & - 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 - - hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & - ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] + (ccohort_hydr%qtop) * 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(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] 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(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] 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%flc_aroot(1) * number_fraction + mean_aroot * number_fraction hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & - ccohort_hydr%flc_troot(1) * 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(1) * number_fraction ! [-] + ccohort_hydr%btran * number_fraction ! [-] endif @@ -3712,14 +3668,6 @@ 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 - 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 @@ -3808,7 +3756,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 @@ -3842,18 +3790,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', & @@ -4044,65 +3992,106 @@ 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', & - 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='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', & - 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_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', & - 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-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 ) 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', & + 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', & + 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', & + 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', & 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='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', & + 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 call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & @@ -4162,54 +4151,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 @@ -4226,35 +4215,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', & - long='net primary production on the site', use_default='active', & + call this%set_history_var(vname='NPP', units='gC/m^2/s', & + 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 ) 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 @@ -4282,23 +4266,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 @@ -5261,6 +5245,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, & @@ -5342,152 +5331,153 @@ 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', & + call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & + 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_rootuptake_scpf ) + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_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_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_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_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_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_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 32dcc16432..9d5c18bfa5 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -1,14 +1,18 @@ module FatesHydraulicsMemMod use FatesConstantsMod, only : r8 => fates_r8 - use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use FatesConstantsMod, only : fates_unset_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 + use FatesHydroWTFMod, only : wrf_arr_type + use FatesHydroWTFMod, only : wkf_arr_type implicit none private + logical, parameter, public :: use_2d_hydrosolve = .false. + + ! Number of soil layers for indexing cohort fine root quanitities ! NOTE: The hydraulics code does have some capacity to run a single soil ! layer that was developed for comparisons with TFS. However, this has @@ -19,12 +23,12 @@ 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 - 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 @@ -32,12 +36,23 @@ 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, dimension(n_hypool_tot) :: porous_media = (/1,2,3,4,5,5,5,5,5/) - ! number of previous timestep's leaf water potential to be retained - integer, parameter, public :: numLWPmem = 4 + 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 :: rhiz_p_media = 5 + + ! P-V curve: total RWC @ which elastic drainage begins (tfs) [-] + 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_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 ! Note (RGK): uscing nclmax causes annoying circular dependency (this needs EDTypes, EDTypes needs this) @@ -45,30 +60,14 @@ 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 - - ! 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 - - ! 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/) + 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 ! ---------------------------------------------------------------------------------------------- - - ! 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 @@ -78,16 +77,15 @@ 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 - - real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m3) + 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 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,29 +95,15 @@ 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 + 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) @@ -127,16 +111,11 @@ 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 - - real(r8),allocatable :: psisoi_liq_innershell(:) ! Matric potential of the inner rhizosphere shell (MPa) - + ! [kg/m2] 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 @@ -160,84 +139,159 @@ module FatesHydraulicsMemMod ! Draw from or add to this pool when ! insufficient plant water available to ! support transpiration + + + ! Useful diagnostics + ! ---------------------------------------------------------------------------------- + + real(r8),allocatable :: sapflow_scpf(:,:) ! flow at base of tree (+ upward) [kg/ha/s] + ! discretized by size x pft + + ! 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) - ! 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(:) + 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 + - contains - procedure :: InitHydrSite + 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 :: 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(:) - 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) + real(r8), allocatable :: kmax_up(:) + real(r8), allocatable :: kmax_dn(:) + + + contains + + procedure :: InitHydrSite + procedure :: SetConnections + procedure :: FlushSiteScratch + end type ed_site_hydr_type - !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. - ! 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] + + + ! Node heights of compartments [m] + ! Heights are referenced to soil surface (+ = above; - = below) + ! 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 ! height of transporting root node + + + ! Maximum hydraulic conductances [kg H2O 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 + 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 + ! 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] 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) :: 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] - 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] - real(r8) :: th_troot(n_hypool_troot) ! water in belowground compartments [kgh2o/indiv] - 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 + + + ! 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),allocatable :: th_aroot(:) ! water in absorbing roots [kgh2o/indiv] + + + ! 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] + + + real(r8) :: qtop ! mean transpiration flux rate [kg/cohort/s] + + + ! 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 - 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. @@ -250,38 +304,36 @@ 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 :: 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 - ! (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 - 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] - 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] - ! BC PLANT HYDRAULICS - flags - logical :: is_newly_recruited !whether the new cohort is newly recruited + 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 + + + + + + ! 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 @@ -289,32 +341,26 @@ module FatesHydraulicsMemMod end type ed_cohort_hydr_type - ! Make public necessary subroutines and functions - public :: InitHydraulicsDerived - 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%z_node_aroot(1:nlevsoil_hydr)) - allocate(this%kmax_treebg_layer(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)) - + 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 @@ -323,106 +369,214 @@ 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_lower) + 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%ftc_aroot) return end subroutine DeallocateHydrCohortArrays ! =================================================================================== - subroutine InitHydrSite(this) + subroutine InitHydrSite(this,numpft,numlevsclass) ! Arguments class(ed_site_hydr_type),intent(inout) :: this - - associate( nlevsoil_hyd => this%nlevsoi_hyd ) + integer,intent(in) :: numpft + integer,intent(in) :: numlevsclass + + 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_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 - 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 - 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 - - 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 + ! We have separate water transfer functions and parameters + ! for each soil layer, and each plant compartment type + 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) * 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() + + end associate - + 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 + subroutine FlushSiteScratch(this) + class(ed_site_hydr_type),intent(inout) :: this + + if(use_2d_hydrosolve) then + 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 + ! =================================================================================== + subroutine SetConnections(this) + + class(ed_site_hydr_type),intent(inout) :: this + + integer :: k, j + integer :: num_cnxs + integer :: num_nds + integer :: nt_ab + integer :: node_tr_end + + num_cnxs = 0 + num_nds = 0 + do k = 1, n_hypool_leaf + num_cnxs = num_cnxs + 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_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_node(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 + + 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%nlevrhiz + 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_node(num_nds) = aroot_p_media + else + this%conn_dn(num_cnxs) = num_nds - 1 + this%conn_up(num_cnxs) = num_nds + this%pm_node(num_nds) = rhiz_p_media + endif + enddo + end do + else + + 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 + + end subroutine SetConnections + end module FatesHydraulicsMemMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 1001ef3bd8..1fddc28def 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -9,649 +9,84 @@ 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 EDTypesMod , only : element_pos - 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 PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon - ! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP - + 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(=) - - 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 - - integer, public :: hlm_use_fixed_biogeog ! Flag to use FATES fixed biogeography mode - ! 1 = TRUE, 0 = FALSE - - integer, public :: hlm_use_nocomp ! Flag to use FATES no PFT competition mode - ! 1 = TRUE, 0 = FALSE - + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - ! ------------------------------------------------------------------------------------- - ! Parameters that are dictated by FATES and known to be required knowledge - ! needed by the HLMs - ! ------------------------------------------------------------------------------------- + ! Just use everything from FatesInterfaceTypesMod, this is + ! its sister code + use FatesInterfaceTypesMod - ! 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 - + implicit none - 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 - ! ------------------------------------------------------------------------------------ + private + character(len=*), parameter :: sourcefile = & + __FILE__ - ! ------------------------------------------------------------------------------------- - ! 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 - - ! 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) - - - ! Fixed biogeography mode - real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT - - - 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] - - - - 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 public :: SetFatesTime - public :: set_fates_global_elements + public :: SetFatesGlobalElements public :: FatesReportParameters - public :: InitPARTEHGlobals public :: allocate_bcin public :: allocate_bcout + public :: zero_bcs + public :: set_bcs contains - ! ==================================================================================== + ! ==================================================================================== subroutine FatesInterfaceInit(log_unit,global_verbose) - + use FatesGlobals, only : FatesGlobalsInit - + implicit none - + integer, intent(in) :: log_unit logical, intent(in) :: global_verbose @@ -659,29 +94,143 @@ 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 + + ! ==================================================================================== - ! ==================================================================================== - + subroutine zero_bcs(fates,s) + + type(fates_interface_type), intent(inout) :: fates + integer, intent(in) :: s + + ! Input boundaries + + 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) @@ -693,7 +242,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 @@ -794,10 +342,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)) @@ -811,6 +360,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in) return end subroutine allocate_bcin + + ! ==================================================================================== subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) @@ -889,128 +440,15 @@ 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 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 - 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) ! -------------------------------------------------------------------------------- ! @@ -1024,8 +462,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 @@ -1033,15 +470,14 @@ 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) + subroutine SetFatesGlobalElements(use_fates) ! -------------------------------------------------------------------------------- ! @@ -1059,18 +495,14 @@ 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? - integer :: i if (use_fates) then - + ! first read the non-PFT parameters call FatesReadParameters() @@ -1093,7 +525,7 @@ subroutine set_fates_global_elements(use_fates) 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. & @@ -1104,6 +536,15 @@ 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 ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays @@ -1165,6 +606,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() + + ! 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() @@ -1183,9 +639,61 @@ subroutine set_fates_global_elements(use_fates) end if - end subroutine set_fates_global_elements + end subroutine SetFatesGlobalElements - !============================================================================================== + ! ====================================================================== + + 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 @@ -1483,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' @@ -1691,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 @@ -1787,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') @@ -1883,7 +1393,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) return end subroutine set_fates_ctrlparms - + ! ==================================================================================== subroutine FatesReportParameters(masterproc) @@ -1903,58 +1413,5 @@ subroutine FatesReportParameters(masterproc) return end subroutine FatesReportParameters - ! ==================================================================================== - - 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 diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 new file mode 100644 index 0000000000..1b3dce4bd8 --- /dev/null +++ b/main/FatesInterfaceTypesMod.F90 @@ -0,0 +1,592 @@ +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 + + 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 :: 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 :: hlm_ivis ! The HLMs assumption of the array index associated with the + ! visible portion of the spectrum in short-wave radiation arrays + + 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 :: hlm_numlevgrnd ! Number of ground layers + ! NOTE! SOIL LAYERS ARE NOT A GLOBAL, THEY + ! ARE VARIABLE BY SITE + + integer, public :: hlm_is_restart ! Is the HLM signalling that this is a restart + ! type simulation? + ! 1=TRUE, 0=FALSE + + 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 + ! ATS, ALM and CLM will only want variables + ! specficially packaged for them. + ! This string sets which filter is enacted. + + + 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 :: 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 :: 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 :: 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 :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive + ! Transport (exensible) Hypothesis (PARTEH) to use + + + 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 :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE + ! 1 = TRUE, 0 = FALSE + + + integer, public :: hlm_use_logging ! This flag signals whether or not to use + ! the logging module + + 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 :: hlm_use_cohort_age_tracking ! This flag signals whether or not to use + ! cohort age tracking. 1 = TRUE, 0 = FALSE + + 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 + ! 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 :: 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 :: 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 :: 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 + + 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 + ! ------------------------------------------------------------------------------------- + + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + 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 + ! 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 :: 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 :: 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 :: 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 :: 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) + ! 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 + ! --------------------------------------------------------------------------------- + + ! 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) + + ! Fixed biogeography mode + real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT + + 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(:) + + + end type fates_interface_type + + + contains + + ! ==================================================================================== + + + + 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 5ea5c615a9..164a1cae35 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -14,30 +14,31 @@ 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 use FatesHydraulicsMemMod, only : n_hypool_troot use FatesHydraulicsMemMod, only : nlevsoi_hyd_max + use FatesPlantHydraulicsMod, only : UpdatePlantPsiFTCFromTheta use PRTGenericMod, only : prt_global use EDCohortDynamicsMod, only : nan_cohort use EDCohortDynamicsMod, only : zero_cohort 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 use PRTGenericMod, only : prt_global use EDTypesMod, only : num_elements + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -180,12 +181,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 @@ -925,7 +926,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', & @@ -935,7 +936,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', & @@ -945,7 +946,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, & @@ -1364,7 +1365,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 @@ -1415,8 +1416,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 @@ -1697,23 +1698,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, & + call this%SetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & 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 @@ -1942,7 +1942,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) = & @@ -1977,7 +1977,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 @@ -2169,8 +2169,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 @@ -2473,18 +2473,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, & + 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) + + call UpdatePlantPsiFTCFromTheta(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, & @@ -2628,7 +2628,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) = & @@ -2663,7 +2663,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) @@ -2709,7 +2708,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 diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 067ca4155f..c3868851cc 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -199,9 +199,9 @@ 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 = "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" ; @@ -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" ; @@ -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" ; @@ -902,12 +902,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 ; 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 diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index a805d58a96..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 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 +650,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 +663,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 +680,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 diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index f2e1729de2..12fb552cdc 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,10 @@ 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: + rename_pft = True # # try: @@ -90,6 +95,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 +177,44 @@ 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 + pftnamelist = [] + npftnames = ncfile.variables['fates_pftname'].shape[0] + for i in range(npftnames): + 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.') + 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: + 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: @@ -217,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 #